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
 529       let ii = [i1;i2;i3] in
 530
 531       (* The newswitchi is for the labels to know where to attach.
 532        * The newendswitch (endi) is for the 'break'. *)
 533       let newswitchi=
 534         !g +> add_node (SwitchHeader(stmt,(e,ii))) lbl "switch" in
 535       let newendswitch =
 536         !g +> add_node (EndStatement (Some iifakeend)) lbl "[endswitch]" in
 537
 538       !g +> add_arc_opt (starti, newswitchi);
 539
 540        (* call compound case. Need special info to pass to compound case
 541         * because we need to build a context_info that need some of the
 542         * information build inside the compound case: the nodei of {
 543         *)
 544        let finalthen =
 545          match Ast_c.unwrap_st st with
 546          | Ast_c.Compound statxs ->
 547
 548              let statxs = Lib.stmt_elems_of_sequencable statxs in
 549
 550              (* todo? we should not allow to match a stmt that corresponds
 551               * to a compound of a switch, so really SeqStart (stmt, ...)
 552               * here ? so maybe should change the SeqStart labeling too.
 553               * So need pass a todo_in_compound2 function.
 554               *)
 555              let todo_in_compound newi newxi =
 556                let newxi' = { newxi with
 557                  ctx = SwitchInfo (newi(*!!*), newendswitch, xi.braces, lbl);
 558                  ctx_stack = newxi.ctx::newxi.ctx_stack
 559                }
 560                in
 561                !g#add_arc ((newswitchi, newi), Direct);
 562                (* new: if have not a default case, then must add an edge
 563                 * between start to end.
 564                 * todo? except if the case[range] coverthe whole spectrum
 565                 *)
 566                if not (statxs +> List.exists (fun x ->
 567                  match Ast_c.unwrap_st x with
 568                  | Labeled (Ast_c.Default _) -> true
 569                  | _ -> false
 570                ))
 571                then begin
 572                  (* when there is no default, then a valid path is
 573                   * from the switchheader to the end. In between we
 574                   * add a Fallthrough.
 575                   *)
 576
 577                  let newafter = !g+>add_node FallThroughNode lbl "[switchfall]"
 578                  in
 579                  !g#add_arc ((newafter, newendswitch), Direct);
 580                  !g#add_arc ((newswitchi, newafter), Direct);
 581                  (* old:
 582                     !g#add_arc ((newswitchi, newendswitch), Direct) +> adjust_g;
 583                  *)
 584                end;
 585                newxi'
 586              in
 587              let newxi = { xi_lbl with compound_caller = (* was xi *)
 588                  Switch todo_in_compound
 589              }
 590              in
 591              aux_statement (None (* no starti *), newxi) st
 592          | _x ->
 593              (* apparently gcc allows some switch body such as
 594               *   switch (i) case 0 : printf("here\n");
 595               *   cf tests-bis/switch_no_body.c
 596               * but I don't think it's worthwile to handle
 597               * such pathological and rare case. Not worth
 598               * the complexity. Safe to assume a coumpound.
 599               *)
 600              raise (Error (WeirdSwitch (pinfo_of_ii [i1])))
 601        in
 602        !g +> add_arc_opt (finalthen, newendswitch);
 603
 604
 605        (* what if has only returns inside. We must  try to see if the
 606         * newendswitch has been used via a 'break;'  or because no
 607         * 'default:')
 608         *)
 609        let res =
 610          (match finalthen with
 611          | Some finalthen ->
 612
 613              let afteri = !g +> add_node AfterNode lbl "[after]" in
 614              !g#add_arc ((newswitchi, afteri),  Direct);
 615              !g#add_arc ((afteri, newendswitch), Direct);
 616
 617
 618              !g#add_arc ((finalthen, newendswitch), Direct);
 619              Some newendswitch
 620          | None ->
 621              if (!g#predecessors newendswitch)#null
 622              then begin
 623                  assert ((!g#successors newendswitch)#null);
 624                  !g#del_node newendswitch;
 625                  None
 626              end
 627              else begin
 628
 629                let afteri = !g +> add_node AfterNode lbl "[after]" in
 630                !g#add_arc ((newswitchi, afteri),  Direct);
 631                !g#add_arc ((afteri, newendswitch), Direct);
 632
 633
 634                Some newendswitch
 635              end
 636          )
 637        in
 638        res
 639
 640
 641   | Labeled (Ast_c.Case  (_, _))
 642   | Labeled (Ast_c.CaseRange  (_, _, _)) ->
 643
 644       incr counter_for_switch;
 645       let switchrank = !counter_for_switch in
 646       let node, st =
 647         match Ast_c.get_st_and_ii stmt with
 648         | Labeled (Ast_c.Case  (e, st)), ii ->
 649             (Case (stmt, (e, ii))),  st
 650         | Labeled (Ast_c.CaseRange  (e, e2, st)), ii ->
 651             (CaseRange (stmt, ((e, e2), ii))), st
 652         | _ -> raise (Impossible 63)
 653       in
 654
 655       let newi = !g +> add_node node  lbl "case:" in
 656
 657       (match Common.optionise (fun () ->
 658         (* old: xi.ctx *)
 659         (xi.ctx::xi.ctx_stack) +> Common.find_some (function
 660         | SwitchInfo (a, b, c, _) -> Some (a, b, c)
 661         | _ -> None
 662         ))
 663       with
 664       | Some (startbrace, switchendi, _braces) ->
 665           (* no need to attach to previous for the first case, cos would be
 666            * redundant. *)
 667           starti +> do_option (fun starti ->
 668             if starti <> startbrace
 669             then !g +> add_arc_opt (Some starti, newi);
 670             );
 671
 672           let s = ("[casenode] " ^ i_to_s switchrank) in
 673           let newcasenodei = !g +> add_node (CaseNode switchrank) lbl s in
 674           !g#add_arc ((startbrace, newcasenodei), Direct);
 675           !g#add_arc ((newcasenodei, newi), Direct);
 676       | None -> raise (Error (CaseNoSwitch (pinfo_of_ii ii)))
 677       );
 678       aux_statement (Some newi, xi_lbl) st
 679
 680
 681   | Labeled (Ast_c.Default st) ->
 682       incr counter_for_switch;
 683       let switchrank = !counter_for_switch in
 684
 685       let newi = !g +> add_node (Default(stmt, ((),ii))) lbl "case default:" in
 686       !g +> add_arc_opt (starti, newi);
 687
 688       (match xi.ctx with
 689       | SwitchInfo (startbrace, switchendi, _braces, _parent_lbl) ->
 690           let s = ("[casenode] " ^ i_to_s switchrank) in
 691           let newcasenodei = !g +> add_node (CaseNode switchrank) lbl s in
 692           !g#add_arc ((startbrace, newcasenodei), Direct);
 693           !g#add_arc ((newcasenodei, newi), Direct);
 694       | _ -> raise (Error (CaseNoSwitch (pinfo_of_ii ii)))
 695       );
 696       aux_statement (Some newi, xi_lbl) st
 697
 698
 699
 700
 701
 702
 703    (* ------------------------- *)
 704   | Iteration  (Ast_c.While (e, st)) ->
 705      (* starti -> newi ---> newfakethen -> ... -> finalthen -
 706       *             |---|-----------------------------------|
 707       *                 |-> newfakelse
 708       *)
 709
 710       let (i1,i2,i3, iifakeend) = tuple_of_list4 ii in
 711       let ii = [i1;i2;i3] in
 712
 713       let newi = !g +> add_node (WhileHeader (stmt, (e,ii))) lbl "while" in
 714       !g +> add_arc_opt (starti, newi);
 715       let newfakethen = !g +> add_node InLoopNode  lbl "[whiletrue]" in
 716       (* let newfakeelse = !g +> add_node FalseNode lbl "[endwhile]" in *)
 717       let newafter = !g +> add_node LoopFallThroughNode lbl "[whilefall]" in
 718       let newfakeelse =
 719         !g +> add_node (EndStatement (Some iifakeend)) lbl "[endwhile]" in
 720
 721       let newxi = { xi_lbl with
 722          ctx = LoopInfo (newi, newfakeelse,  xi_lbl.braces, lbl);
 723          ctx_stack = xi_lbl.ctx::xi_lbl.ctx_stack
 724         }
 725       in
 726
 727       !g#add_arc ((newi, newfakethen), Direct);
 728       !g#add_arc ((newafter, newfakeelse), Direct);
 729       !g#add_arc ((newi, newafter), Direct);
 730       let finalthen = aux_statement (Some newfakethen, newxi) st in
 731       !g +> add_arc_opt
 732         (finalthen, if !Flag_parsing_c.no_loops then newafter else newi);
 733       Some newfakeelse
 734
 735
 736   (* This time, may return None, for instance if goto in body of dowhile
 737    * (whereas While cant return None). But if return None, certainly
 738    * some deadcode.
 739    *)
 740   | Iteration  (Ast_c.DoWhile (st, e)) ->
 741      (* starti -> doi ---> ... ---> finalthen (opt) ---> whiletaili
 742       *             |--------- newfakethen ---------------|  |---> newfakelse
 743       *)
 744       let is_zero =
 745         match Ast_c.unwrap_expr e with
 746         | Constant (Int ("0",_)) -> true
 747         | _ -> false
 748       in
 749
 750       let (iido, iiwhiletail, iifakeend) =
 751         match ii with
 752         | [i1;i2;i3;i4;i5;i6] -> i1, [i2;i3;i4;i5], i6
 753         | _ -> raise (Impossible 64)
 754       in
 755       let doi = !g +> add_node (DoHeader (stmt, iido))  lbl "do" in
 756       !g +> add_arc_opt (starti, doi);
 757       let taili = !g +> add_node (DoWhileTail (e, iiwhiletail)) lbl "whiletail"
 758       in
 759
 760
 761       (*let newfakeelse = !g +> add_node FalseNode lbl "[enddowhile]" in *)
 762       let newafter = !g +> add_node FallThroughNode lbl "[dowhilefall]" in
 763       let newfakeelse =
 764         !g +> add_node (EndStatement (Some iifakeend)) lbl "[enddowhile]" in
 765
 766       let afteri = !g +> add_node AfterNode lbl "[after]" in
 767       !g#add_arc ((doi,afteri), Direct);
 768       !g#add_arc ((afteri,newfakeelse), Direct);
 769
 770       let newxi = { xi_lbl with
 771          ctx = LoopInfo (taili, newfakeelse, xi_lbl.braces, lbl);
 772          ctx_stack = xi_lbl.ctx::xi_lbl.ctx_stack
 773         }
 774       in
 775
 776       if not is_zero && (not !Flag_parsing_c.no_loops)
 777       then begin
 778         let newfakethen = !g +> add_node InLoopNode lbl "[dowhiletrue]" in
 779         !g#add_arc ((taili, newfakethen), Direct);
 780         !g#add_arc ((newfakethen, doi), Direct);
 781       end;
 782
 783       !g#add_arc ((newafter, newfakeelse), Direct);
 784       !g#add_arc ((taili, newafter), Direct);
 785
 786
 787       let finalthen = aux_statement (Some doi, newxi) st in
 788       (match finalthen with
 789       | None ->
 790           if (!g#predecessors taili)#null
 791           then raise (Error (DeadCode (Some (pinfo_of_ii ii))))
 792           else Some newfakeelse
 793       | Some finali ->
 794           !g#add_arc ((finali, taili), Direct);
 795           Some newfakeelse
 796       )
 797
 798
 799
 800   | Iteration  (Ast_c.For (e1opt, e2opt, e3opt, st)) ->
 801       let (i1,i2,i3, iifakeend) = tuple_of_list4 ii in
 802       let ii = [i1;i2;i3] in
 803
 804       let newi =
 805         !g+>add_node(ForHeader(stmt,((e1opt,e2opt,e3opt),ii))) lbl "for" in
 806       !g +> add_arc_opt (starti, newi);
 807       let newfakethen = !g +> add_node InLoopNode  lbl "[fortrue]" in
 808       (*let newfakeelse = !g +> add_node FalseNode lbl "[endfor]" in*)
 809       let newafter = !g +> add_node LoopFallThroughNode lbl "[forfall]" in
 810       let newfakeelse =
 811         !g +> add_node (EndStatement (Some iifakeend)) lbl "[endfor]" in
 812
 813       let newxi = { xi_lbl with
 814            ctx = LoopInfo (newi, newfakeelse, xi_lbl.braces, lbl);
 815            ctx_stack = xi_lbl.ctx::xi_lbl.ctx_stack
 816         }
 817       in
 818
 819       !g#add_arc ((newi, newfakethen), Direct);
 820       !g#add_arc ((newafter, newfakeelse), Direct);
 821       !g#add_arc ((newi, newafter), Direct);
 822       let finalthen = aux_statement (Some newfakethen, newxi) st in
 823       !g +> add_arc_opt
 824         (finalthen,
 825          if !Flag_parsing_c.no_loops then newafter else newi);
 826       Some newfakeelse
 827
 828
 829   (* to generate less exception with the breakInsideLoop, analyse
 830    * correctly the loop deguisé comme list_for_each. Add a case ForMacro
 831    * in ast_c (and in lexer/parser), and then do code that imitates the
 832    * code for the For.
 833    * update: the list_for_each was previously converted into Tif by the
 834    * lexer, now they are returned as Twhile so less pbs. But not perfect.
 835    * update: now I recognize the list_for_each macro so no more problems.
 836    *)
 837   | Iteration  (Ast_c.MacroIteration (s, es, st)) ->
 838       let (i1,i2,i3, iifakeend) = tuple_of_list4 ii in
 839       let ii = [i1;i2;i3] in
 840
 841       let newi =
 842         !g+>add_node(MacroIterHeader(stmt,((s,es),ii))) lbl "foreach" in
 843       !g +> add_arc_opt (starti, newi);
 844       let newfakethen = !g +> add_node InLoopNode  lbl "[fortrue]" in
 845       (*let newfakeelse = !g +> add_node FalseNode lbl "[endfor]" in*)
 846       let newafter = !g +> add_node LoopFallThroughNode lbl "[foreachfall]" in
 847       let newfakeelse =
 848         !g +> add_node (EndStatement (Some iifakeend)) lbl "[endforeach]" in
 849
 850       let newxi = { xi_lbl with
 851            ctx = LoopInfo (newi, newfakeelse, xi_lbl.braces, lbl);
 852            ctx_stack = xi_lbl.ctx::xi_lbl.ctx_stack
 853         }
 854       in
 855
 856       !g#add_arc ((newi, newfakethen), Direct);
 857       !g#add_arc ((newafter, newfakeelse), Direct);
 858       !g#add_arc ((newi, newafter), Direct);
 859       let finalthen = aux_statement (Some newfakethen, newxi) st in
 860       !g +> add_arc_opt
 861         (finalthen,
 862          if !Flag_parsing_c.no_loops then newafter else newi);
 863       Some newfakeelse
 864
 865
 866
 867    (* ------------------------- *)
 868   | Jump ((Ast_c.Continue|Ast_c.Break) as x) ->
 869       let context_info =
 870         match xi.ctx with
 871           SwitchInfo (startbrace, loopendi, braces, parent_lbl) ->
 872             if x =*= Ast_c.Break
 873             then xi.ctx
 874             else
 875               (try
 876                 xi.ctx_stack +> Common.find_some (function
 877                     LoopInfo (_,_,_,_) as c ->  Some c
 878                   | _ -> None)
 879               with Not_found ->
 880                 raise (Error (OnlyBreakInSwitch (pinfo_of_ii ii))))
 881         | LoopInfo (loopstarti, loopendi, braces, parent_lbl) -> xi.ctx
 882         | NoInfo -> raise (Error (NoEnclosingLoop (pinfo_of_ii ii))) in
 883
 884       let parent_label =
 885         match context_info with
 886           LoopInfo (loopstarti, loopendi, braces, parent_lbl) -> parent_lbl
 887         | SwitchInfo (startbrace, loopendi, braces, parent_lbl) -> parent_lbl
 888         | NoInfo -> raise (Impossible 65) in
 889
 890       (* flow_to_ast: *)
 891       let (node_info, string) =
 892         let parent_string =
 893           String.concat "," (List.map string_of_int parent_label) in
 894         (match x with
 895           | Ast_c.Continue ->
 896               (Continue (stmt, ((), ii)),
 897                Printf.sprintf "continue; [%s]" parent_string)
 898           | Ast_c.Break    ->
 899               (Break    (stmt, ((), ii)),
 900                Printf.sprintf "break; [%s]" parent_string)
 901           | _ -> raise (Impossible 66)
 902           ) in
 903
 904       (* idea: break or continue records the label of its parent loop or
 905          switch *)
 906       let newi = !g +> add_bc_node node_info lbl parent_label string in
 907       !g +> add_arc_opt (starti, newi);
 908
 909       (* let newi = some starti in *)
 910
 911       (match context_info with
 912       | LoopInfo (loopstarti, loopendi, braces, parent_lbl) ->
 913           let desti =
 914             (match x with
 915             | Ast_c.Break -> loopendi
 916             | Ast_c.Continue ->
 917                 (* if no loops, then continue behaves like break - just
 918                    one iteration *)
 919                 if !Flag_parsing_c.no_loops then loopendi else loopstarti
 920             | x -> raise (Impossible 67)
 921             ) in
 922           let difference = List.length xi.braces - List.length braces in
 923           assert (difference >= 0);
 924           let toend = take difference xi.braces in
 925           let newi = insert_all_braces toend newi in
 926           !g#add_arc ((newi, desti), Direct);
 927           None
 928
 929       | SwitchInfo (startbrace, loopendi, braces, parent_lbl) ->
 930           assert (x =*= Ast_c.Break);
 931           let difference = List.length xi.braces - List.length braces in
 932           assert (difference >= 0);
 933           let toend = take difference xi.braces in
 934           let newi = insert_all_braces toend newi in
 935           !g#add_arc ((newi, loopendi), Direct);
 936           None
 937       | NoInfo -> raise (Impossible 68)
 938       )
 939
 940   | Jump ((Ast_c.Return | Ast_c.ReturnExpr _) as kind) ->
 941      (match xi.exiti, xi.errorexiti with
 942      | None, None -> raise (Error (NoExit (pinfo_of_ii ii)))
 943      | Some exiti, Some errorexiti ->
 944
 945       (* flow_to_ast: *)
 946       let s =
 947         match kind with
 948         | Ast_c.Return -> "return"
 949         | Ast_c.ReturnExpr _ -> "return ..."
 950         | _ -> raise (Impossible 69)
 951       in
 952       let newi =
 953         !g +> add_node
 954           (match kind with
 955           | Ast_c.Return ->       Return (stmt, ((),ii))
 956           | Ast_c.ReturnExpr e -> ReturnExpr (stmt, (e, ii))
 957           | _ -> raise (Impossible 70)
 958           )
 959           lbl s
 960       in
 961       !g +> add_arc_opt (starti, newi);
 962       let newi = insert_all_braces xi.braces newi in
 963
 964       if xi.under_ifthen
 965       then !g#add_arc ((newi, errorexiti), Direct)
 966       else !g#add_arc ((newi, exiti), Direct)
 967       ;
 968       None
 969      | _ -> raise (Impossible 71)
 970      )
 971
 972
 973   (* ------------------------- *)
 974   | Ast_c.Decl decl ->
 975      let s =
 976        match decl with
 977        | (Ast_c.DeclList
 978              ([{v_namei = Some (name, _); v_type = typ; v_storage = sto}, _], _)) ->
 979            "decl:" ^ Ast_c.str_of_name name
 980        | _ -> "decl_novar_or_multivar"
 981      in
 982
 983      let newi = !g +> add_node (Decl (decl)) lbl s in
 984      !g +> add_arc_opt (starti, newi);
 985      Some newi
 986
 987   (* ------------------------- *)
 988   | Ast_c.Asm body ->
 989       let newi = !g +> add_node (Asm (stmt, ((body,ii)))) lbl "asm;" in
 990       !g +> add_arc_opt (starti, newi);
 991       Some newi
 992
 993   | Ast_c.MacroStmt ->
 994       let newi = !g +> add_node (MacroStmt (stmt, ((),ii))) lbl "macro;" in
 995       !g +> add_arc_opt (starti, newi);
 996       Some newi
 997
 998
 999   (* ------------------------- *)
1000   | Ast_c.NestedFunc def ->
1001       raise (Error NestedFunc)
1002
1003
1004
1005
1006
1007
1008
1009 and aux_statement_list starti (xi, newxi) statxs =
1010   statxs
1011   +> List.fold_left (fun starti statement_seq ->
1012     if !Flag_parsing_c.label_strategy_2
1013     then incr counter_for_labels;
1014
1015     let newxi' =
1016       if !Flag_parsing_c.label_strategy_2
1017       then { newxi with labels = xi.labels @ [ !counter_for_labels ] }
1018       else newxi
1019     in
1020
1021     match statement_seq with
1022     | Ast_c.StmtElem statement ->
1023         aux_statement (starti, newxi') statement
1024
1025     | Ast_c.CppDirectiveStmt directive ->
1026         pr2_once ("ast_to_flow: filter a directive");
1027         starti
1028
1029     | Ast_c.IfdefStmt ifdef ->
1030         pr2_once ("ast_to_flow: filter a directive");
1031         starti
1032
1033     | Ast_c.IfdefStmt2 (ifdefs, xxs) ->
1034
1035         let (head, body, tail) = Common.head_middle_tail ifdefs in
1036
1037         let newi =
1038           !g +> add_node (IfdefHeader (head)) newxi'.labels "[ifdef]" in
1039         let taili =
1040           !g +> add_node (IfdefEndif (tail)) newxi'.labels "[endif]" in
1041         (* do like for a close brace, see endi.{c,cocci} *)
1042         let taili_dup =
1043           mk_fake_node (IfdefEndif (tail)) newxi'.labels [] "[endif]" in
1044         !g +> add_arc_opt (starti, newi);
1045
1046         let elsenodes =
1047           body +> List.map (fun elseif ->
1048             let elsei =
1049               !g +> add_node (IfdefElse (elseif)) newxi'.labels "[elseif]" in
1050             !g#add_arc ((newi, elsei), Direct);
1051             elsei
1052           ) in
1053
1054         let _finalxs =
1055           Common.zip (newi::elsenodes) xxs +> List.map (fun (start_nodei, xs)->
1056             (* not sure if this is correct... newxi seems to relate to
1057                the assigned level number *)
1058             let newerxi =
1059               { newxi with braces = taili_dup:: newxi.braces } in
1060             let finalthen =
1061               aux_statement_list (Some start_nodei) (newxi, newerxi) xs in
1062             !g +> add_arc_opt (finalthen, taili);
1063           )
1064         in
1065
1066 (*
1067         This is an attempt to let a statement metavariable match this
1068         construct, but it doesn't work because #ifdef is not a statement.
1069         Not sure if this is a good or bad thing, at least if there is no else
1070         because then no statement might be there.
1071         let afteri = !g +> add_node AfterNode newxi'.labels "[after]" in
1072         !g#add_arc ((newi, afteri), Direct);
1073         !g#add_arc ((afteri, taili), Direct);
1074 *)
1075
1076         Some taili
1077
1078   ) starti
1079
1080
1081 (*****************************************************************************)
1082 (* Definition of function *)
1083 (*****************************************************************************)
1084
1085 let (aux_definition: nodei -> definition -> unit) = fun topi funcdef ->
1086
1087   let lbl_start = [!counter_for_labels] in
1088
1089   let ({f_name = namefuncs;
1090         f_type = functype;
1091         f_storage= sto;
1092         f_body= compound;
1093         f_attr= attrs;
1094         f_old_c_style = oldstyle;
1095         }, ii) = funcdef in
1096   let iifunheader, iicompound =
1097     (match ii with
1098     | ioparen::icparen::iobrace::icbrace::iifake::isto ->
1099         ioparen::icparen::iifake::isto,
1100         [iobrace;icbrace]
1101     | _ -> raise (Impossible 72)
1102     )
1103   in
1104
1105   let topstatement = Ast_c.mk_st (Ast_c.Compound compound) iicompound in
1106
1107   let headi = !g +> add_node
1108     (FunHeader ({
1109       Ast_c.f_name = namefuncs;
1110       f_type = functype;
1111       f_storage = sto;
1112       f_attr = attrs;
1113       f_body = [] (* empty body *);
1114       f_old_c_style = oldstyle;
1115       }, iifunheader))
1116     lbl_start ("function " ^ Ast_c.str_of_name namefuncs) in
1117   let enteri     = !g +> add_node Enter     lbl_0 "[enter]"     in
1118   let exiti      = !g +> add_node Exit      lbl_0 "[exit]"      in
1119   let errorexiti = !g +> add_node ErrorExit lbl_0 "[errorexit]" in
1120
1121   !g#add_arc ((topi, headi), Direct);
1122   !g#add_arc ((headi, enteri), Direct);
1123
1124   (* ---------------------------------------------------------------- *)
1125   (* todocheck: assert ? such as we have "consommer" tous les labels  *)
1126   let info =
1127     { initial_info with
1128       labels = lbl_start;
1129       labels_assoc = compute_labels_and_create_them topstatement;
1130       exiti      = Some exiti;
1131       errorexiti = Some errorexiti;
1132       compound_caller = FunctionDef;
1133     }
1134   in
1135
1136   let lasti = aux_statement (Some enteri, info) topstatement in
1137   !g +> add_arc_opt (lasti, exiti)
1138
1139 (*****************************************************************************)
1140 (* Entry point *)
1141 (*****************************************************************************)
1142
1143 (* Helpers for SpecialDeclMacro.
1144  *
1145  * could also force the coccier to define
1146  * the toplevel macro statement as in @@ toplevel_declarator MACRO_PARAM;@@
1147  * and so I would not need this hack and instead I would to a cleaner
1148  * match in cocci_vs_c_3.ml of a A.MacroTop vs B.MacroTop
1149  *
1150  * todo: update: now I do what I just described, so can remove this code ?
1151  *)
1152 let specialdeclmacro_to_stmt (s, args, ii) =
1153   let (iis, iiopar, iicpar, iiptvirg) = tuple_of_list4 ii in
1154   let ident = Ast_c.RegularName (s, [iis]) in
1155   let identfinal = Ast_c.mk_e (Ast_c.Ident (ident)) Ast_c.noii in
1156   let f = Ast_c.mk_e (Ast_c.FunCall (identfinal, args)) [iiopar;iicpar] in
1157   let stmt = Ast_c.mk_st (Ast_c.ExprStatement (Some f)) [iiptvirg] in
1158   stmt,  (f, [iiptvirg])
1159
1160
1161
1162 let rec ast_to_control_flow e =
1163
1164   (* globals (re)initialialisation *)
1165   g := (new ograph_mutable);
1166   counter_for_labels := 1;
1167   counter_for_braces := 0;
1168   counter_for_switch := 0;
1169
1170   let topi = !g +> add_node TopNode lbl_0 "[top]" in
1171
1172   match e with
1173   | Ast_c.Namespace (defs, _) ->
1174       (* todo: incorporate the other defs *)
1175       let rec loop defs =
1176         match defs with
1177         | [] -> None
1178         | def :: defs ->
1179             match ast_to_control_flow def with
1180             | None -> loop defs
1181             | x -> x in
1182       loop defs
1183   | Ast_c.Definition ((defbis,_) as def) ->
1184       let _funcs = defbis.f_name in
1185       let _c = defbis.f_body in
1186       (* if !Flag.show_misc then pr2 ("build info function " ^ funcs); *)
1187       aux_definition topi def;
1188       Some !g
1189
1190   | Ast_c.Declaration _
1191   | Ast_c.CppTop (Ast_c.Include _)
1192   | Ast_c.MacroTop _
1193     ->
1194       let (elem, str) =
1195         match e with
1196         | Ast_c.Declaration decl ->
1197             (Control_flow_c.Decl decl),  "decl"
1198         | Ast_c.CppTop (Ast_c.Include inc) ->
1199             (Control_flow_c.Include inc), "#include"
1200         | Ast_c.MacroTop (s, args, ii) ->
1201             let (st, (e, ii)) = specialdeclmacro_to_stmt (s, args, ii) in
1202             (Control_flow_c.ExprStatement (st, (Some e, ii))), "macrotoplevel"
1203           (*(Control_flow_c.MacroTop (s, args,ii), "macrotoplevel") *)
1204         | _ -> raise (Impossible 73)
1205       in
1206       let ei =   !g +> add_node elem    lbl_0 str in
1207       let endi = !g +> add_node EndNode lbl_0 "[end]" in
1208
1209       !g#add_arc ((topi, ei),Direct);
1210       !g#add_arc ((ei, endi),Direct);
1211       Some !g
1212
1213   | Ast_c.CppTop (Ast_c.Define ((id,ii), (defkind, defval)))  ->
1214       let s =
1215         match defkind with
1216           Ast_c.Undef -> "#undef " ^ id
1217         | _ -> "#define " ^ id in
1218       let headeri = !g+>add_node (DefineHeader ((id, ii), defkind)) lbl_0 s in
1219       !g#add_arc ((topi, headeri),Direct);
1220
1221       (match defval with
1222       | Ast_c.DefineExpr e ->
1223           let ei   = !g +> add_node (DefineExpr e) lbl_0 "defexpr" in
1224           let endi = !g +> add_node EndNode        lbl_0 "[end]" in
1225           !g#add_arc ((headeri, ei) ,Direct);
1226           !g#add_arc ((ei, endi) ,Direct);
1227
1228       | Ast_c.DefineType ft ->
1229           let ei   = !g +> add_node (DefineType ft) lbl_0 "deftyp" in
1230           let endi = !g +> add_node EndNode         lbl_0 "[end]" in
1231           !g#add_arc ((headeri, ei) ,Direct);
1232           !g#add_arc ((ei, endi) ,Direct);
1233
1234       | Ast_c.DefineStmt st ->
1235           (* can have some return; inside the statement *)
1236           let exiti      = !g +> add_node Exit      lbl_0 "[exit]"      in
1237           let errorexiti = !g +> add_node ErrorExit lbl_0 "[errorexit]" in
1238           let goto_labels = compute_labels_and_create_them st in
1239
1240           let info = { initial_info with
1241             labels_assoc = goto_labels;
1242             exiti      = Some exiti;
1243             errorexiti = Some errorexiti;
1244           }
1245           in
1246
1247           let lasti = aux_statement (Some headeri , info) st in
1248           lasti +> do_option (fun lasti ->
1249             (* todo? if don't have a lasti ? no EndNode ? CTL will work ? *)
1250             let endi = !g +> add_node EndNode lbl_0 "[end]" in
1251             !g#add_arc ((lasti, endi), Direct)
1252           )
1253
1254
1255       | Ast_c.DefineDoWhileZero ((st,_e), ii) ->
1256           let goto_labels = compute_labels_and_create_them st in
1257           let info = { initial_info with
1258             labels_assoc = goto_labels } in
1259
1260           let headerdoi =
1261             !g +> add_node (DefineDoWhileZeroHeader ((),ii)) lbl_0 "do0" in
1262           !g#add_arc ((headeri, headerdoi), Direct);
1263           let lasti = aux_statement (Some headerdoi , info) st in
1264           lasti +> do_option (fun lasti ->
1265             let endi = !g +> add_node EndNode lbl_0 "[end]" in
1266             !g#add_arc ((lasti, endi), Direct)
1267           )
1268
1269       | Ast_c.DefineFunction def ->
1270           aux_definition headeri def;
1271
1272       | Ast_c.DefineText (s, s_ii) ->
1273           raise (Error(Define(pinfo_of_ii ii)))
1274       | Ast_c.DefineEmpty ->
1275           let endi = !g +> add_node EndNode lbl_0 "[end]" in
1276           !g#add_arc ((headeri, endi),Direct);
1277       | Ast_c.DefineInit _ ->
1278           raise (Error(Define(pinfo_of_ii ii)))
1279       | Ast_c.DefineMulti sts -> (* christia: todo *)
1280           raise (Error(Define(pinfo_of_ii ii)))
1281       | Ast_c.DefineTodo ->
1282           raise (Error(Define(pinfo_of_ii ii)))
1283
1284 (* old:
1285       | Ast_c.DefineText (s, ii) ->
1286           let endi = !g +> add_node EndNode lbl_0 "[end]" in
1287           !g#add_arc ((headeri, endi),Direct);
1288       | Ast_c.DefineInit _ ->
1289           let endi = !g +> add_node EndNode lbl_0 "[end]" in
1290           !g#add_arc ((headeri, endi),Direct);
1291       | Ast_c.DefineTodo ->
1292           let endi = !g +> add_node EndNode lbl_0 "[end]" in
1293           !g#add_arc ((headeri, endi),Direct);
1294 *)
1295       );
1296
1297       Some !g
1298
1299   | _ -> None
1300
1301
1302 (*****************************************************************************)
1303 (* CFG loop annotation *)
1304 (*****************************************************************************)
1305
1306 let annotate_loop_nodes g =
1307   let firsti = Control_flow_c.first_node g in
1308
1309   (* just for opti a little *)
1310   let already = Hashtbl.create 101 in
1311
1312   g +> Ograph_extended.dfs_iter_with_path firsti (fun xi path ->
1313     Hashtbl.add already xi true;
1314     let succ = g#successors xi in
1315     let succ = succ#tolist in
1316     succ +> List.iter (fun (yi,_edge) ->
1317       if Hashtbl.mem already yi && List.mem yi (xi::path)
1318       then
1319         let node = g#nodes#find yi in
1320         let ((node2, nodeinfo), nodestr) = node in
1321         let node' = ((node2, {nodeinfo with is_loop = true}), (nodestr ^ "*"))
1322         in g#replace_node (yi, node');
1323     );
1324   );
1325
1326
1327   g
1328
1329
1330 (*****************************************************************************)
1331 (* CFG checks *)
1332 (*****************************************************************************)
1333
1334 (* the second phase, deadcode detection. Old code was raising DeadCode if
1335  * lasti = None, but maybe not. In fact if have 2 return in the then
1336  * and else of an if ?
1337  *
1338  * alt: but can assert that at least there exist
1339  * a node to exiti, just check #pred of exiti.
1340  *
1341  * Why so many deadcode in Linux ? Ptet que le label est utilisé
1342  * mais dans le corps d'une macro et donc on le voit pas :(
1343  *
1344  *)
1345 let deadcode_detection g =
1346
1347   g#nodes#iter (fun (k, node) ->
1348     let pred = g#predecessors k in
1349     if pred#null then
1350       (match unwrap node with
1351       (* old:
1352        * | Enter -> ()
1353        * | EndStatement _ -> pr2 "deadcode sur fake node, pas grave";
1354        *)
1355       | TopNode -> ()
1356       | FunHeader _ -> ()
1357       | ErrorExit -> ()
1358       | Exit -> ()     (* if have 'loop: if(x) return; i++; goto loop' *)
1359       | SeqEnd _ -> () (* todo?: certaines '}' deviennent orphelins *)
1360       | x ->
1361           (match Control_flow_c.extract_fullstatement node with
1362           | Some st ->
1363               let ii = Ast_c.get_ii_st_take_care st in
1364               raise (Error (DeadCode (Some (pinfo_of_ii ii))))
1365           | _ -> pr2 "CFG: orphelin nodes, maybe something weird happened"
1366           )
1367       )
1368   )
1369
1370 (*------------------------------------------------------------------------*)
1371 (* special_cfg_braces: the check are really specific to the way we
1372  * have build our control_flow, with the { } in the graph so normally
1373  * all those checks here are useless.
1374  *
1375  * ver1: to better error reporting, to report earlier the message, pass
1376  * the list of '{' (containing morover a brace_identifier) instead of
1377  * just the depth.
1378  *)
1379
1380 let (check_control_flow: cflow -> unit) = fun g ->
1381
1382   let nodes = g#nodes  in
1383   let starti = first_node g in
1384   let visited = ref (new oassocb []) in
1385
1386   let print_trace_error xs =  pr2 "PB with flow:";  Common.pr2_gen xs; in
1387
1388   let rec dfs (nodei, (* Depth depth,*) startbraces,  trace)  =
1389     let trace2 = nodei::trace in
1390     if !visited#haskey nodei
1391     then
1392       (* if loop back, just check that go back to a state where have same depth
1393          number *)
1394       let (*(Depth depth2)*) startbraces2 = !visited#find nodei in
1395       if  (*(depth = depth2)*) startbraces <> startbraces2
1396       then
1397         begin
1398           pr2 (sprintf "PB with flow: the node %d has not same braces count"
1399                  nodei);
1400           print_trace_error trace2
1401         end
1402     else
1403       let children = g#successors nodei in
1404       let _ = visited := !visited#add (nodei, (* Depth depth*) startbraces) in
1405
1406       (* old: good, but detect a missing } too late, only at the end
1407       let newdepth =
1408         (match fst (nodes#find nodei) with
1409         | StartBrace i -> Depth (depth + 1)
1410         | EndBrace i   -> Depth (depth - 1)
1411         | _ -> Depth depth
1412         )
1413       in
1414       *)
1415       let newdepth =
1416         (match unwrap (nodes#find nodei),  startbraces with
1417         | SeqStart (_,i,_), xs  -> i::xs
1418         | SeqEnd (i,_), j::xs ->
1419             if i =|= j
1420             then xs
1421             else
1422               begin
1423                 pr2 (sprintf ("PB with flow: not corresponding match between }%d and excpeted }%d at node %d") i j nodei);
1424                 print_trace_error trace2;
1425                 xs
1426               end
1427         | SeqEnd (i,_), [] ->
1428             pr2 (sprintf "PB with flow: too much } at }%d " i);
1429             print_trace_error trace2;
1430             []
1431         | _, xs ->  xs
1432         )
1433       in
1434
1435
1436       if null children#tolist
1437       then
1438         if (* (depth = 0) *) startbraces <> []
1439         then print_trace_error trace2
1440       else
1441         children#tolist +> List.iter (fun (nodei,_) ->
1442           dfs (nodei, newdepth, trace2)
1443         )
1444     in
1445
1446   dfs (starti, (* Depth 0*) [], [])
1447
1448 (*****************************************************************************)
1449 (* Error report *)
1450 (*****************************************************************************)
1451
1452 let report_error error =
1453   let error_from_info info =
1454     Common.error_message_short info.file ("", info.charpos)
1455   in
1456   match error with
1457   | DeadCode          infoopt ->
1458       (match infoopt with
1459       | None ->   pr2 "FLOW: deadcode detected, but cant trace back the place"
1460       | Some info -> pr2 ("FLOW: deadcode detected: " ^ error_from_info info)
1461       )
1462   | CaseNoSwitch      info ->
1463       pr2 ("FLOW: case without corresponding switch: " ^ error_from_info info)
1464   | OnlyBreakInSwitch info ->
1465       pr2 ("FLOW: only break are allowed in switch: " ^ error_from_info info)
1466   | WeirdSwitch info ->
1467       pr2 ("FLOW: weird switch: " ^ error_from_info info)
1468   | NoEnclosingLoop   (info) ->
1469       pr2 ("FLOW: can't find enclosing loop: " ^ error_from_info info)
1470   | GotoCantFindLabel (s, info) ->
1471       pr2 ("FLOW: cant jump to " ^ s ^ ": because we can't find this label")
1472   | NoExit info ->
1473       pr2 ("FLOW: can't find exit or error exit: " ^ error_from_info info)
1474   | DuplicatedLabel s ->
1475       pr2 ("FLOW: duplicate label " ^ s)
1476   | NestedFunc  ->
1477       pr2 ("FLOW: not handling yet nested function")
1478   | ComputedGoto ->
1479       pr2 ("FLOW: not handling computed goto yet")
1480   | Define info ->
1481       pr2 ("Unsupported form of #define: " ^ error_from_info info)