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