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