337a49188262941f4e550e8366e5fa3197e24227
[bpt/coccinelle.git] / cocci.ml
1 (*
2 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
3 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
4 * This file is part of Coccinelle.
5 *
6 * Coccinelle is free software: you can redistribute it and/or modify
7 * it under the terms of the GNU General Public License as published by
8 * the Free Software Foundation, according to version 2 of the License.
9 *
10 * Coccinelle 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 * GNU General Public License for more details.
14 *
15 * You should have received a copy of the GNU General Public License
16 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
17 *
18 * The authors reserve the right to distribute this or future versions of
19 * Coccinelle under other licenses.
20 *)
21
22
23 open Common
24
25 module CCI = Ctlcocci_integration
26 module TAC = Type_annoter_c
27
28 (*****************************************************************************)
29 (* This file is a kind of driver. It gathers all the important functions
30 * from coccinelle in one place. The different entities in coccinelle are:
31 * - files
32 * - astc
33 * - astcocci
34 * - flow (contain nodes)
35 * - ctl (contain rule_elems)
36 * This file contains functions to transform one in another.
37 *)
38 (*****************************************************************************)
39
40 (* --------------------------------------------------------------------- *)
41 (* C related *)
42 (* --------------------------------------------------------------------- *)
43 let cprogram_of_file file =
44 let (program2, _stat) = Parse_c.parse_print_error_heuristic file in
45 program2
46
47 let cprogram_of_file_cached file =
48 let (program2, _stat) = Parse_c.parse_cache file in
49 if !Flag_cocci.ifdef_to_if
50 then
51 program2 +> Parse_c.with_program2 (fun asts ->
52 Cpp_ast_c.cpp_ifdef_statementize asts
53 )
54 else program2
55
56 let cfile_of_program program2_with_ppmethod outf =
57 Unparse_c.pp_program program2_with_ppmethod outf
58
59 (* for memoization, contains only one entry, the one for the SP *)
60 let _hparse = Hashtbl.create 101
61 let _hctl = Hashtbl.create 101
62
63 (* --------------------------------------------------------------------- *)
64 (* Cocci related *)
65 (* --------------------------------------------------------------------- *)
66 let sp_of_file2 file iso =
67 Common.memoized _hparse (file, iso) (fun () ->
68 Parse_cocci.process file iso false)
69 let sp_of_file file iso =
70 Common.profile_code "parse cocci" (fun () -> sp_of_file2 file iso)
71
72
73 (* --------------------------------------------------------------------- *)
74 (* Flow related *)
75 (* --------------------------------------------------------------------- *)
76 let print_flow flow =
77 Ograph_extended.print_ograph_mutable flow "/tmp/test.dot" true
78
79
80 let ast_to_flow_with_error_messages2 x =
81 let flowopt =
82 try Ast_to_flow.ast_to_control_flow x
83 with Ast_to_flow.Error x ->
84 Ast_to_flow.report_error x;
85 None
86 in
87 flowopt +> do_option (fun flow ->
88 (* This time even if there is a deadcode, we still have a
89 * flow graph, so I can try the transformation and hope the
90 * deadcode will not bother us.
91 *)
92 try Ast_to_flow.deadcode_detection flow
93 with Ast_to_flow.Error (Ast_to_flow.DeadCode x) ->
94 Ast_to_flow.report_error (Ast_to_flow.DeadCode x);
95 );
96 flowopt
97 let ast_to_flow_with_error_messages a =
98 Common.profile_code "flow" (fun () -> ast_to_flow_with_error_messages2 a)
99
100
101 (* --------------------------------------------------------------------- *)
102 (* Ctl related *)
103 (* --------------------------------------------------------------------- *)
104
105 let ctls_of_ast2 ast ua pos =
106 List.map2
107 (function ast -> function (ua,pos) ->
108 List.combine
109 (if !Flag_cocci.popl
110 then failwith "no popl here" (* Popl.popl ast *)
111 else Asttoctl2.asttoctl ast ua pos)
112 (Asttomember.asttomember ast ua))
113 ast (List.combine ua pos)
114
115 let ctls_of_ast ast ua =
116 Common.profile_code "asttoctl2" (fun () -> ctls_of_ast2 ast ua)
117
118 (*****************************************************************************)
119 (* Some debugging functions *)
120 (*****************************************************************************)
121
122 (* the inputs *)
123
124 let show_or_not_cfile2 cfile =
125 if !Flag_cocci.show_c then begin
126 Common.pr2_xxxxxxxxxxxxxxxxx ();
127 pr2 ("processing C file: " ^ cfile);
128 Common.pr2_xxxxxxxxxxxxxxxxx ();
129 Common.command2 ("cat " ^ cfile);
130 end
131 let show_or_not_cfile a =
132 Common.profile_code "show_xxx" (fun () -> show_or_not_cfile2 a)
133
134 let show_or_not_cfiles cfiles = List.iter show_or_not_cfile cfiles
135
136
137 let show_or_not_cocci2 coccifile isofile =
138 if !Flag_cocci.show_cocci then begin
139 Common.pr2_xxxxxxxxxxxxxxxxx ();
140 pr2 ("processing semantic patch file: " ^ coccifile);
141 isofile +> (fun s -> pr2 ("with isos from: " ^ s));
142 Common.pr2_xxxxxxxxxxxxxxxxx ();
143 Common.command2 ("cat " ^ coccifile);
144 pr2 "";
145 end
146 let show_or_not_cocci a b =
147 Common.profile_code "show_xxx" (fun () -> show_or_not_cocci2 a b)
148
149 (* the output *)
150
151 let show_or_not_diff2 cfile outfile show_only_minus =
152 if !Flag_cocci.show_diff then begin
153 match Common.fst(Compare_c.compare_default cfile outfile) with
154 Compare_c.Correct -> () (* diff only in spacing, etc *)
155 | _ ->
156 (* may need --strip-trailing-cr under windows *)
157 pr2 "diff = ";
158
159 let line =
160 match !Flag_parsing_c.diff_lines with
161 | None -> "diff -u -p " ^ cfile ^ " " ^ outfile
162 | Some n -> "diff -U "^n^" -p "^cfile^" "^outfile in
163 let xs =
164 let res = Common.cmd_to_list line in
165 match (!Flag.patch,res) with
166 (* create something that looks like the output of patch *)
167 (Some prefix,minus_file::plus_file::rest) ->
168 let drop_prefix file =
169 if prefix =$= ""
170 then "/"^file
171 else
172 let lp = String.length prefix in
173 String.sub file lp ((String.length file) - lp) in
174 let diff_line =
175 match List.rev(Str.split (Str.regexp " ") line) with
176 new_file::old_file::cmdrev ->
177 if !Flag.sgrep_mode2
178 then
179 String.concat " "
180 (List.rev ("/tmp/nothing" :: old_file :: cmdrev))
181 else
182 let old_base_file = drop_prefix old_file in
183 String.concat " "
184 (List.rev
185 (("b"^old_base_file)::("a"^old_base_file)::cmdrev))
186 | _ -> failwith "bad command" in
187 let (minus_line,plus_line) =
188 if !Flag.sgrep_mode2
189 then (minus_file,plus_file)
190 else
191 match (Str.split (Str.regexp "[ \t]") minus_file,
192 Str.split (Str.regexp "[ \t]") plus_file) with
193 ("---"::old_file::old_rest,"+++"::new_file::new_rest) ->
194 let old_base_file = drop_prefix old_file in
195 (String.concat " "
196 ("---"::("a"^old_base_file)::old_rest),
197 String.concat " "
198 ("+++"::("b"^old_base_file)::new_rest))
199 | (l1,l2) ->
200 failwith
201 (Printf.sprintf "bad diff header lines: %s %s"
202 (String.concat ":" l1) (String.concat ":" l2)) in
203 diff_line::minus_line::plus_line::rest
204 | _ -> res in
205 xs +> List.iter (fun s ->
206 if s =~ "^\\+" && show_only_minus
207 then ()
208 else pr s)
209 end
210 let show_or_not_diff a b c =
211 Common.profile_code "show_xxx" (fun () -> show_or_not_diff2 a b c)
212
213
214 (* the derived input *)
215
216 let show_or_not_ctl_tex2 astcocci ctls =
217 if !Flag_cocci.show_ctl_tex then begin
218 Ctltotex.totex ("/tmp/__cocci_ctl.tex") astcocci ctls;
219 Common.command2 ("cd /tmp; latex __cocci_ctl.tex; " ^
220 "dvips __cocci_ctl.dvi -o __cocci_ctl.ps;" ^
221 "gv __cocci_ctl.ps &");
222 end
223 let show_or_not_ctl_tex a b =
224 Common.profile_code "show_xxx" (fun () -> show_or_not_ctl_tex2 a b)
225
226
227
228 let show_or_not_rule_name ast rulenb =
229 if !Flag_cocci.show_ctl_text or !Flag.show_trying or
230 !Flag.show_transinfo or !Flag_cocci.show_binding_in_out
231 then
232 begin
233 let name =
234 match ast with
235 Ast_cocci.CocciRule (nm, (deps, drops, exists), x, _, _) -> nm
236 | _ -> i_to_s rulenb in
237 Common.pr_xxxxxxxxxxxxxxxxx ();
238 pr (name ^ " = ");
239 Common.pr_xxxxxxxxxxxxxxxxx ()
240 end
241
242 let show_or_not_scr_rule_name rulenb =
243 if !Flag_cocci.show_ctl_text or !Flag.show_trying or
244 !Flag.show_transinfo or !Flag_cocci.show_binding_in_out
245 then
246 begin
247 let name = i_to_s rulenb in
248 Common.pr_xxxxxxxxxxxxxxxxx ();
249 pr ("script rule " ^ name ^ " = ");
250 Common.pr_xxxxxxxxxxxxxxxxx ()
251 end
252
253 let show_or_not_ctl_text2 ctl ast rulenb =
254 if !Flag_cocci.show_ctl_text then begin
255
256 adjust_pp_with_indent (fun () ->
257 Format.force_newline();
258 Pretty_print_cocci.print_plus_flag := true;
259 Pretty_print_cocci.print_minus_flag := true;
260 Pretty_print_cocci.unparse ast;
261 );
262
263 pr "CTL = ";
264 let (ctl,_) = ctl in
265 adjust_pp_with_indent (fun () ->
266 Format.force_newline();
267 Pretty_print_engine.pp_ctlcocci
268 !Flag_cocci.show_mcodekind_in_ctl !Flag_cocci.inline_let_ctl ctl;
269 );
270 pr "";
271 end
272 let show_or_not_ctl_text a b c =
273 Common.profile_code "show_xxx" (fun () -> show_or_not_ctl_text2 a b c)
274
275
276
277 (* running information *)
278 let get_celem celem : string =
279 match celem with
280 Ast_c.Definition ({Ast_c.f_name = namefuncs;},_) ->
281 Ast_c.str_of_name namefuncs
282 | Ast_c.Declaration
283 (Ast_c.DeclList ([{Ast_c.v_namei = Some (name, _);}, _], _)) ->
284 Ast_c.str_of_name name
285 | _ -> ""
286
287 let show_or_not_celem2 prelude celem =
288 let (tag,trying) =
289 (match celem with
290 | Ast_c.Definition ({Ast_c.f_name = namefuncs},_) ->
291 let funcs = Ast_c.str_of_name namefuncs in
292 Flag.current_element := funcs;
293 (" function: ",funcs)
294 | Ast_c.Declaration
295 (Ast_c.DeclList ([{Ast_c.v_namei = Some (name,_)}, _], _)) ->
296 let s = Ast_c.str_of_name name in
297 Flag.current_element := s;
298 (" variable ",s);
299 | _ ->
300 Flag.current_element := "something_else";
301 (" ","something else");
302 ) in
303 if !Flag.show_trying then pr2 (prelude ^ tag ^ trying)
304
305 let show_or_not_celem a b =
306 Common.profile_code "show_xxx" (fun () -> show_or_not_celem2 a b)
307
308
309 let show_or_not_trans_info2 trans_info =
310 if !Flag.show_transinfo then begin
311 if null trans_info then pr2 "transformation info is empty"
312 else begin
313 pr2 "transformation info returned:";
314 let trans_info =
315 List.sort (function (i1,_,_) -> function (i2,_,_) -> compare i1 i2)
316 trans_info
317 in
318 indent_do (fun () ->
319 trans_info +> List.iter (fun (i, subst, re) ->
320 pr2 ("transform state: " ^ (Common.i_to_s i));
321 indent_do (fun () ->
322 adjust_pp_with_indent_and_header "with rule_elem: " (fun () ->
323 Pretty_print_cocci.print_plus_flag := true;
324 Pretty_print_cocci.print_minus_flag := true;
325 Pretty_print_cocci.rule_elem "" re;
326 );
327 adjust_pp_with_indent_and_header "with binding: " (fun () ->
328 Pretty_print_engine.pp_binding subst;
329 );
330 )
331 );
332 )
333 end
334 end
335 let show_or_not_trans_info a =
336 Common.profile_code "show_xxx" (fun () -> show_or_not_trans_info2 a)
337
338
339
340 let show_or_not_binding2 s binding =
341 if !Flag_cocci.show_binding_in_out then begin
342 adjust_pp_with_indent_and_header ("binding " ^ s ^ " = ") (fun () ->
343 Pretty_print_engine.pp_binding binding
344 )
345 end
346 let show_or_not_binding a b =
347 Common.profile_code "show_xxx" (fun () -> show_or_not_binding2 a b)
348
349
350
351 (*****************************************************************************)
352 (* Some helper functions *)
353 (*****************************************************************************)
354
355 let worth_trying cfiles tokens =
356 (* drop the following line for a list of list by rules. since we don't
357 allow multiple minirules, all the tokens within a rule should be in
358 a single CFG entity *)
359 let tokens = Common.union_all tokens in
360 if not !Flag_cocci.windows && not (null tokens)
361 then
362 (* could also modify the code in get_constants.ml *)
363 let tokens = tokens +> List.map (fun s ->
364 match () with
365 | _ when s =~ "^[A-Za-z_][A-Za-z_0-9]*$" ->
366 "\\b" ^ s ^ "\\b"
367
368 | _ when s =~ "^[A-Za-z_]" ->
369 "\\b" ^ s
370
371 | _ when s =~ ".*[A-Za-z_]$" ->
372 s ^ "\\b"
373 | _ -> s
374
375 ) in
376 let com = sprintf "egrep -q '(%s)' %s" (join "|" tokens) (join " " cfiles)
377 in
378 (match Sys.command com with
379 | 0 (* success *) -> true
380 | _ (* failure *) ->
381 (if !Flag.show_misc
382 then Printf.printf "grep failed: %s\n" com);
383 false (* no match, so not worth trying *)
384 )
385 else true
386
387 let check_macro_in_sp_and_adjust tokens =
388 let tokens = Common.union_all tokens in
389 tokens +> List.iter (fun s ->
390 if Hashtbl.mem !Parsing_hacks._defs s
391 then begin
392 pr2 "warning: macro in semantic patch was in macro definitions";
393 pr2 ("disabling macro expansion for " ^ s);
394 Hashtbl.remove !Parsing_hacks._defs s
395 end
396 )
397
398
399 let contain_loop gopt =
400 match gopt with
401 | Some g ->
402 g#nodes#tolist +> List.exists (fun (xi, node) ->
403 Control_flow_c.extract_is_loop node
404 )
405 | None -> true (* means nothing, if no g then will not model check *)
406
407
408
409 let sp_contain_typed_metavar_z toplevel_list_list =
410 let bind x y = x or y in
411 let option_default = false in
412 let mcode _ _ = option_default in
413 let donothing r k e = k e in
414
415 let expression r k e =
416 match Ast_cocci.unwrap e with
417 | Ast_cocci.MetaExpr (_,_,_,Some t,_,_) -> true
418 | Ast_cocci.MetaExpr (_,_,_,_,Ast_cocci.LocalID,_) -> true
419 | _ -> k e
420 in
421
422 let combiner =
423 Visitor_ast.combiner bind option_default
424 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
425 donothing donothing donothing donothing
426 donothing expression donothing donothing donothing donothing donothing
427 donothing donothing donothing donothing donothing
428 in
429 toplevel_list_list +>
430 List.exists
431 (function (nm,_,rule) ->
432 (List.exists combiner.Visitor_ast.combiner_top_level rule))
433
434
435 let sp_contain_typed_metavar rules =
436 sp_contain_typed_metavar_z
437 (List.map
438 (function x ->
439 match x with
440 Ast_cocci.CocciRule (a,b,c,d,_) -> (a,b,c)
441 | _ -> failwith "error in filter")
442 (List.filter
443 (function x ->
444 match x with
445 Ast_cocci.CocciRule (a,b,c,d,Ast_cocci.Normal) -> true
446 | _ -> false)
447 rules))
448
449
450
451 (* finding among the #include the one that we need to parse
452 * because they may contain useful type definition or because
453 * we may have to modify them
454 *
455 * For the moment we base in part our heuristic on the name of the file, e.g.
456 * serio.c is related we think to #include <linux/serio.h>
457 *)
458
459 let interpret_include_path _ =
460 match !Flag_cocci.include_path with
461 None -> "include"
462 | Some x -> x
463
464 let (includes_to_parse:
465 (Common.filename * Parse_c.program2) list ->
466 Flag_cocci.include_options -> 'a) = fun xs choose_includes ->
467 match choose_includes with
468 Flag_cocci.I_UNSPECIFIED -> failwith "not possible"
469 | Flag_cocci.I_NO_INCLUDES -> []
470 | x ->
471 let all_includes = x =*= Flag_cocci.I_ALL_INCLUDES in
472 xs +> List.map (fun (file, cs) ->
473 let dir = Common.dirname file in
474
475 cs +> Common.map_filter (fun (c,_info_item) ->
476 match c with
477 | Ast_c.CppTop
478 (Ast_c.Include
479 {Ast_c.i_include = ((x,ii)); i_rel_pos = info_h_pos;}) ->
480 (match x with
481 | Ast_c.Local xs ->
482 let f = Filename.concat dir (Common.join "/" xs) in
483 (* for our tests, all the files are flat in the current dir *)
484 if not (Sys.file_exists f) && !Flag_cocci.relax_include_path
485 then
486 let attempt2 = Filename.concat dir (Common.last xs) in
487 if not (Sys.file_exists f) && all_includes
488 then Some (Filename.concat (interpret_include_path())
489 (Common.join "/" xs))
490 else Some attempt2
491 else Some f
492
493 | Ast_c.NonLocal xs ->
494 if all_includes ||
495 Common.fileprefix (Common.last xs) =$= Common.fileprefix file
496 then
497 Some (Filename.concat (interpret_include_path())
498 (Common.join "/" xs))
499 else None
500 | Ast_c.Weird _ -> None
501 )
502 | _ -> None))
503 +> List.concat
504 +> Common.uniq
505
506 let rec interpret_dependencies local global = function
507 Ast_cocci.Dep s -> List.mem s local
508 | Ast_cocci.AntiDep s ->
509 (if !Flag_ctl.steps != None
510 then failwith "steps and ! dependency incompatible");
511 not (List.mem s local)
512 | Ast_cocci.EverDep s -> List.mem s global
513 | Ast_cocci.NeverDep s ->
514 (if !Flag_ctl.steps != None
515 then failwith "steps and ! dependency incompatible");
516 not (List.mem s global)
517 | Ast_cocci.AndDep(s1,s2) ->
518 (interpret_dependencies local global s1) &&
519 (interpret_dependencies local global s2)
520 | Ast_cocci.OrDep(s1,s2) ->
521 (interpret_dependencies local global s1) or
522 (interpret_dependencies local global s2)
523 | Ast_cocci.NoDep -> true
524
525 let rec print_dependencies str local global dep =
526 if !Flag_cocci.show_dependencies
527 then
528 begin
529 pr2 str;
530 let seen = ref [] in
531 let rec loop = function
532 Ast_cocci.Dep s | Ast_cocci.AntiDep s ->
533 if not (List.mem s !seen)
534 then
535 begin
536 if List.mem s local
537 then pr2 (s^" satisfied")
538 else pr2 (s^" not satisfied");
539 seen := s :: !seen
540 end
541 | Ast_cocci.EverDep s | Ast_cocci.NeverDep s ->
542 if not (List.mem s !seen)
543 then
544 begin
545 if List.mem s global
546 then pr2 (s^" satisfied")
547 else pr2 (s^" not satisfied");
548 seen := s :: !seen
549 end
550 | Ast_cocci.AndDep(s1,s2) ->
551 loop s1;
552 loop s2
553 | Ast_cocci.OrDep(s1,s2) ->
554 loop s1;
555 loop s2
556 | Ast_cocci.NoDep -> () in
557 loop dep
558 end
559
560
561
562 (* --------------------------------------------------------------------- *)
563 (* #include relative position in the file *)
564 (* --------------------------------------------------------------------- *)
565
566 (* compute the set of new prefixes
567 * on
568 * "a/b/x"; (* in fact it is now a list of string so ["a";"b";"x"] *)
569 * "a/b/c/x";
570 * "a/x";
571 * "b/x";
572 * it would give for the first element
573 * ""; "a"; "a/b"; "a/b/x"
574 * for the second
575 * "a/b/c/x"
576 *
577 * update: if the include is inside a ifdef a put nothing. cf -test incl.
578 * this is because we dont want code added inside ifdef.
579 *)
580
581 let compute_new_prefixes xs =
582 xs +> Common.map_withenv (fun already xs ->
583 let subdirs_prefixes = Common.inits xs in
584 let new_first = subdirs_prefixes +> List.filter (fun x ->
585 not (List.mem x already)
586 )
587 in
588 new_first,
589 new_first @ already
590 ) []
591 +> fst
592
593
594 (* does via side effect on the ref in the Include in Ast_c *)
595 let rec update_include_rel_pos cs =
596 let only_include = cs +> Common.map_filter (fun c ->
597 match c with
598 | Ast_c.CppTop (Ast_c.Include {Ast_c.i_include = ((x,_));
599 i_rel_pos = aref;
600 i_is_in_ifdef = inifdef}) ->
601 (match x with
602 | Ast_c.Weird _ -> None
603 | _ ->
604 if inifdef
605 then None
606 else Some (x, aref)
607 )
608 | _ -> None
609 )
610 in
611 let (locals, nonlocals) =
612 only_include +> Common.partition_either (fun (c, aref) ->
613 match c with
614 | Ast_c.Local x -> Left (x, aref)
615 | Ast_c.NonLocal x -> Right (x, aref)
616 | Ast_c.Weird x -> raise Impossible
617 ) in
618
619 update_rel_pos_bis locals;
620 update_rel_pos_bis nonlocals;
621 cs
622 and update_rel_pos_bis xs =
623 let xs' = List.map fst xs in
624 let the_first = compute_new_prefixes xs' in
625 let the_last = List.rev (compute_new_prefixes (List.rev xs')) in
626 let merged = Common.zip xs (Common.zip the_first the_last) in
627 merged +> List.iter (fun ((x, aref), (the_first, the_last)) ->
628 aref := Some
629 {
630 Ast_c.first_of = the_first;
631 Ast_c.last_of = the_last;
632 }
633 )
634
635
636
637
638
639
640 (*****************************************************************************)
641 (* All the information needed around the C elements and Cocci rules *)
642 (*****************************************************************************)
643
644 type toplevel_c_info = {
645 ast_c: Ast_c.toplevel; (* contain refs so can be modified *)
646 tokens_c: Parser_c.token list;
647 fullstring: string;
648
649 flow: Control_flow_c.cflow option; (* it's the "fixed" flow *)
650 contain_loop: bool;
651
652 env_typing_before: TAC.environment;
653 env_typing_after: TAC.environment;
654
655 was_modified: bool ref;
656
657 (* id: int *)
658 }
659
660 type toplevel_cocci_info_script_rule = {
661 scr_ast_rule: string * (string * (string * string)) list * string;
662 language: string;
663 scr_dependencies: Ast_cocci.dependency;
664 scr_ruleid: int;
665 script_code: string;
666 }
667
668 type toplevel_cocci_info_cocci_rule = {
669 ctl: Lib_engine.ctlcocci * (CCI.pred list list);
670 metavars: Ast_cocci.metavar list;
671 ast_rule: Ast_cocci.rule;
672 isexp: bool; (* true if + code is an exp, only for Flag.make_hrule *)
673
674 rulename: string;
675 dependencies: Ast_cocci.dependency;
676 (* There are also some hardcoded rule names in parse_cocci.ml:
677 * let reserved_names = ["all";"optional_storage";"optional_qualifier"]
678 *)
679 dropped_isos: string list;
680 free_vars: Ast_cocci.meta_name list;
681 negated_pos_vars: Ast_cocci.meta_name list;
682 used_after: Ast_cocci.meta_name list;
683 positions: Ast_cocci.meta_name list;
684
685 ruleid: int;
686 ruletype: Ast_cocci.ruletype;
687
688 was_matched: bool ref;
689 }
690
691 type toplevel_cocci_info =
692 ScriptRuleCocciInfo of toplevel_cocci_info_script_rule
693 | InitialScriptRuleCocciInfo of toplevel_cocci_info_script_rule
694 | FinalScriptRuleCocciInfo of toplevel_cocci_info_script_rule
695 | CocciRuleCocciInfo of toplevel_cocci_info_cocci_rule
696
697 type cocci_info = toplevel_cocci_info list * string list list (* tokens *)
698
699 type kind_file = Header | Source
700 type file_info = {
701 fname : string;
702 full_fname : string;
703 was_modified_once: bool ref;
704 asts: toplevel_c_info list;
705 fpath : string;
706 fkind : kind_file;
707 }
708
709 let g_contain_typedmetavar = ref false
710
711
712 let last_env_toplevel_c_info xs =
713 (Common.last xs).env_typing_after
714
715 let concat_headers_and_c (ccs: file_info list)
716 : (toplevel_c_info * string) list =
717 (List.concat (ccs +> List.map (fun x ->
718 x.asts +> List.map (fun x' ->
719 (x', x.fname)))))
720
721 let for_unparser xs =
722 xs +> List.map (fun x ->
723 (x.ast_c, (x.fullstring, x.tokens_c)), Unparse_c.PPviastr
724 )
725
726 let gen_pdf_graph () =
727 (Ctl_engine.get_graph_files ()) +> List.iter (fun outfile ->
728 Printf.printf "Generation of %s%!" outfile;
729 let filename_stack = Ctl_engine.get_graph_comp_files outfile in
730 List.iter (fun filename ->
731 ignore (Unix.system ("dot " ^ filename ^ " -Tpdf -o " ^ filename ^ ".pdf;"))
732 ) filename_stack;
733 let (head,tail) = (List.hd filename_stack, List.tl filename_stack) in
734 ignore(Unix.system ("cp " ^ head ^ ".pdf " ^ outfile ^ ".pdf;"));
735 tail +> List.iter (fun filename ->
736 ignore(Unix.system ("mv " ^ outfile ^ ".pdf /tmp/tmp.pdf;"));
737 ignore(Unix.system ("pdftk " ^ filename ^ ".pdf /tmp/tmp.pdf cat output " ^ outfile ^ ".pdf"));
738 );
739 ignore(Unix.system ("rm /tmp/tmp.pdf;"));
740 List.iter (fun filename ->
741 ignore (Unix.system ("rm " ^ filename ^ " " ^ filename ^ ".pdf;"))
742 ) filename_stack;
743 Printf.printf " - Done\n")
744
745
746 (* --------------------------------------------------------------------- *)
747 let prepare_cocci ctls free_var_lists negated_pos_lists
748 used_after_lists positions_list metavars astcocci =
749
750 let gathered = Common.index_list_1
751 (zip (zip (zip (zip (zip (zip ctls metavars) astcocci) free_var_lists)
752 negated_pos_lists) used_after_lists) positions_list)
753 in
754 gathered +> List.map
755 (fun (((((((ctl_toplevel_list,metavars),ast),free_var_list),
756 negated_pos_list),used_after_list),positions_list),rulenb) ->
757
758 let is_script_rule r =
759 match r with
760 Ast_cocci.ScriptRule _
761 | Ast_cocci.InitialScriptRule _ | Ast_cocci.FinalScriptRule _ -> true
762 | _ -> false in
763
764 if not (List.length ctl_toplevel_list =|= 1) && not (is_script_rule ast)
765 then failwith "not handling multiple minirules";
766
767 match ast with
768 Ast_cocci.ScriptRule (lang,deps,mv,code) ->
769 let r =
770 {
771 scr_ast_rule = (lang, mv, code);
772 language = lang;
773 scr_dependencies = deps;
774 scr_ruleid = rulenb;
775 script_code = code;
776 }
777 in ScriptRuleCocciInfo r
778 | Ast_cocci.InitialScriptRule (lang,code) ->
779 let mv = [] in
780 let deps = Ast_cocci.NoDep in
781 let r =
782 {
783 scr_ast_rule = (lang, mv, code);
784 language = lang;
785 scr_dependencies = deps;
786 scr_ruleid = rulenb;
787 script_code = code;
788 }
789 in InitialScriptRuleCocciInfo r
790 | Ast_cocci.FinalScriptRule (lang,code) ->
791 let mv = [] in
792 let deps = Ast_cocci.NoDep in
793 let r =
794 {
795 scr_ast_rule = (lang, mv, code);
796 language = lang;
797 scr_dependencies = deps;
798 scr_ruleid = rulenb;
799 script_code = code;
800 }
801 in FinalScriptRuleCocciInfo r
802 | Ast_cocci.CocciRule
803 (rulename,(dependencies,dropped_isos,z),restast,isexp,ruletype) ->
804 CocciRuleCocciInfo (
805 {
806 ctl = List.hd ctl_toplevel_list;
807 metavars = metavars;
808 ast_rule = ast;
809 isexp = List.hd isexp;
810 rulename = rulename;
811 dependencies = dependencies;
812 dropped_isos = dropped_isos;
813 free_vars = List.hd free_var_list;
814 negated_pos_vars = List.hd negated_pos_list;
815 used_after = List.hd used_after_list;
816 positions = List.hd positions_list;
817 ruleid = rulenb;
818 ruletype = ruletype;
819 was_matched = ref false;
820 })
821 )
822
823
824 (* --------------------------------------------------------------------- *)
825
826 let build_info_program cprogram env =
827
828 let (cs, parseinfos) =
829 Common.unzip cprogram in
830
831 let alltoks =
832 parseinfos +> List.map (fun (s,toks) -> toks) +> List.flatten in
833
834 (* I use cs' but really annotate_xxx work by doing side effects on cs *)
835 let cs' =
836 Comment_annotater_c.annotate_program alltoks cs in
837 let cs_with_envs =
838 Type_annoter_c.annotate_program env (*!g_contain_typedmetavar*) cs'
839 in
840
841 zip cs_with_envs parseinfos +> List.map (fun ((c, (enva,envb)), parseinfo)->
842 let (fullstr, tokens) = parseinfo in
843
844 let flow =
845 ast_to_flow_with_error_messages c +> Common.map_option (fun flow ->
846 let flow = Ast_to_flow.annotate_loop_nodes flow in
847
848 (* remove the fake nodes for julia *)
849 let fixed_flow = CCI.fix_flow_ctl flow in
850
851 if !Flag_cocci.show_flow then print_flow fixed_flow;
852 if !Flag_cocci.show_before_fixed_flow then print_flow flow;
853
854 fixed_flow
855 )
856 in
857
858 {
859 ast_c = c; (* contain refs so can be modified *)
860 tokens_c = tokens;
861 fullstring = fullstr;
862
863 flow = flow;
864
865 contain_loop = contain_loop flow;
866
867 env_typing_before = enva;
868 env_typing_after = envb;
869
870 was_modified = ref false;
871 }
872 )
873
874
875
876 (* Optimisation. Try not unparse/reparse the whole file when have modifs *)
877 let rebuild_info_program cs file isexp =
878 cs +> List.map (fun c ->
879 if !(c.was_modified)
880 then
881 let file = Common.new_temp_file "cocci_small_output" ".c" in
882 cfile_of_program
883 [(c.ast_c, (c.fullstring, c.tokens_c)), Unparse_c.PPnormal]
884 file;
885
886 (* Common.command2 ("cat " ^ file); *)
887 let cprogram = cprogram_of_file file in
888 let xs = build_info_program cprogram c.env_typing_before in
889
890 (* TODO: assert env has not changed,
891 * if yes then must also reparse what follows even if not modified.
892 * Do that only if contain_typedmetavar of course, so good opti.
893 *)
894 (* Common.list_init xs *) (* get rid of the FinalDef *)
895 xs
896 else [c]
897 ) +> List.concat
898
899
900 let rebuild_info_c_and_headers ccs isexp =
901 ccs +> List.iter (fun c_or_h ->
902 if c_or_h.asts +> List.exists (fun c -> !(c.was_modified))
903 then c_or_h.was_modified_once := true;
904 );
905 ccs +> List.map (fun c_or_h ->
906 { c_or_h with
907 asts = rebuild_info_program c_or_h.asts c_or_h.full_fname isexp }
908 )
909
910
911
912
913
914
915
916 let prepare_c files choose_includes : file_info list =
917 let cprograms = List.map cprogram_of_file_cached files in
918 let includes = includes_to_parse (zip files cprograms) choose_includes in
919
920 (* todo?: may not be good to first have all the headers and then all the c *)
921 let all =
922 (includes +> List.map (fun hpath -> Right hpath))
923 ++
924 ((zip files cprograms) +> List.map (fun (file, asts) -> Left (file, asts)))
925 in
926
927 let env = ref !TAC.initial_env in
928
929 let ccs = all +> Common.map_filter (fun x ->
930 match x with
931 | Right hpath ->
932 if not (Common.lfile_exists hpath)
933 then begin
934 pr2 ("TYPE: header " ^ hpath ^ " not found");
935 None
936 end
937 else
938 let h_cs = cprogram_of_file_cached hpath in
939 let info_h_cs = build_info_program h_cs !env in
940 env :=
941 if null info_h_cs
942 then !env
943 else last_env_toplevel_c_info info_h_cs
944 ;
945 Some {
946 fname = Common.basename hpath;
947 full_fname = hpath;
948 asts = info_h_cs;
949 was_modified_once = ref false;
950 fpath = hpath;
951 fkind = Header;
952 }
953 | Left (file, cprogram) ->
954 (* todo?: don't update env ? *)
955 let cs = build_info_program cprogram !env in
956 (* we do that only for the c, not for the h *)
957 ignore(update_include_rel_pos (cs +> List.map (fun x -> x.ast_c)));
958 Some {
959 fname = Common.basename file;
960 full_fname = file;
961 asts = cs;
962 was_modified_once = ref false;
963 fpath = file;
964 fkind = Source;
965 }
966 )
967 in
968 ccs
969
970
971 (*****************************************************************************)
972 (* Processing the ctls and toplevel C elements *)
973 (*****************************************************************************)
974
975 (* The main algorithm =~
976 * The algorithm is roughly:
977 * for_all ctl rules in SP
978 * for_all minirule in rule (no more)
979 * for_all binding (computed during previous phase)
980 * for_all C elements
981 * match control flow of function vs minirule
982 * with the binding and update the set of possible
983 * bindings, and returned the possibly modified function.
984 * pretty print modified C elements and reparse it.
985 *
986 *
987 * On ne prends que les newbinding ou returned_any_state est vrai.
988 * Si ca ne donne rien, on prends ce qu'il y avait au depart.
989 * Mais au nouveau depart de quoi ?
990 * - si ca donne rien apres avoir traité toutes les fonctions avec ce binding ?
991 * - ou alors si ca donne rien, apres avoir traité toutes les fonctions
992 * avec tous les bindings du round d'avant ?
993 *
994 * Julia pense qu'il faut prendre la premiere solution.
995 * Example: on a deux environnements candidats, E1 et E2 apres avoir traité
996 * la regle ctl 1. On arrive sur la regle ctl 2.
997 * E1 ne donne rien pour la regle 2, on garde quand meme E1 pour la regle 3.
998 * E2 donne un match a un endroit et rend E2' alors on utilise ca pour
999 * la regle 3.
1000 *
1001 * I have not to look at used_after_list to decide to restart from
1002 * scratch. I just need to look if the binding list is empty.
1003 * Indeed, let's suppose that a SP have 3 regions/rules. If we
1004 * don't find a match for the first region, then if this first
1005 * region does not bind metavariable used after, that is if
1006 * used_after_list is empty, then mysat(), even if does not find a
1007 * match, will return a Left, with an empty transformation_info,
1008 * and so current_binding will grow. On the contrary if the first
1009 * region must bind some metavariables used after, and that we
1010 * dont find any such region, then mysat() will returns lots of
1011 * Right, and current_binding will not grow, and so we will have
1012 * an empty list of binding, and we will catch such a case.
1013 *
1014 * opti: julia says that because the binding is
1015 * determined by the used_after_list, the items in the list
1016 * are kind of sorted, so could optimise the insert_set operations.
1017 *)
1018
1019
1020 (* r(ule), c(element in C code), e(nvironment) *)
1021
1022 let merge_env new_e old_e =
1023 List.fold_left
1024 (function old_e ->
1025 function (e,rules) as elem ->
1026 let (same,diff) = List.partition (function (e1,_) -> e =*= e1) old_e in
1027 match same with
1028 [] -> elem :: old_e
1029 | [(_,old_rules)] -> (e,Common.union_set rules old_rules) :: diff
1030 | _ -> failwith "duplicate environment entries")
1031 old_e new_e
1032
1033 let apply_python_rule r cache newes e rules_that_have_matched
1034 rules_that_have_ever_matched =
1035 show_or_not_scr_rule_name r.scr_ruleid;
1036 if not(interpret_dependencies rules_that_have_matched
1037 !rules_that_have_ever_matched r.scr_dependencies)
1038 then
1039 begin
1040 print_dependencies "dependencies for script not satisfied:"
1041 rules_that_have_matched
1042 !rules_that_have_ever_matched r.scr_dependencies;
1043 show_or_not_binding "in environment" e;
1044 (cache, (e, rules_that_have_matched)::newes)
1045 end
1046 else
1047 begin
1048 let (_, mv, _) = r.scr_ast_rule in
1049 if List.for_all (Pycocci.contains_binding e) mv
1050 then
1051 begin
1052 let relevant_bindings =
1053 List.filter
1054 (function ((re,rm),_) ->
1055 List.exists (function (_,(r,m)) -> r =$= re && m =$= rm) mv)
1056 e in
1057 let new_cache =
1058 if List.mem relevant_bindings cache
1059 then cache
1060 else
1061 begin
1062 print_dependencies "dependencies for script satisfied:"
1063 rules_that_have_matched
1064 !rules_that_have_ever_matched r.scr_dependencies;
1065 show_or_not_binding "in" e;
1066 Pycocci.build_classes (List.map (function (x,y) -> x) e);
1067 Pycocci.construct_variables mv e;
1068 let _ = Pycocci.pyrun_simplestring
1069 ("import coccinelle\nfrom coccinelle "^
1070 "import *\ncocci = Cocci()\n" ^
1071 r.script_code) in
1072 relevant_bindings :: cache
1073 end in
1074 if !Pycocci.inc_match
1075 then (new_cache, merge_env [(e, rules_that_have_matched)] newes)
1076 else (new_cache, newes)
1077 end
1078 else (cache, merge_env [(e, rules_that_have_matched)] newes)
1079 end
1080
1081 let rec apply_cocci_rule r rules_that_have_ever_matched es
1082 (ccs:file_info list ref) =
1083 Common.profile_code r.rulename (fun () ->
1084 show_or_not_rule_name r.ast_rule r.ruleid;
1085 show_or_not_ctl_text r.ctl r.ast_rule r.ruleid;
1086
1087 let reorganized_env =
1088 reassociate_positions r.free_vars r.negated_pos_vars !es in
1089
1090 (* looping over the environments *)
1091 let (_,newes (* envs for next round/rule *)) =
1092 List.fold_left
1093 (function (cache,newes) ->
1094 function ((e,rules_that_have_matched),relevant_bindings) ->
1095 if not(interpret_dependencies rules_that_have_matched
1096 !rules_that_have_ever_matched r.dependencies)
1097 then
1098 begin
1099 print_dependencies
1100 ("dependencies for rule "^r.rulename^" not satisfied:")
1101 rules_that_have_matched
1102 !rules_that_have_ever_matched r.dependencies;
1103 show_or_not_binding "in environment" e;
1104 (cache,
1105 merge_env
1106 [(e +> List.filter (fun (s,v) -> List.mem s r.used_after),
1107 rules_that_have_matched)]
1108 newes)
1109 end
1110 else
1111 let new_bindings =
1112 try List.assoc relevant_bindings cache
1113 with
1114 Not_found ->
1115 print_dependencies
1116 ("dependencies for rule "^r.rulename^" satisfied:")
1117 rules_that_have_matched
1118 !rules_that_have_ever_matched r.dependencies;
1119 show_or_not_binding "in" e;
1120 show_or_not_binding "relevant in" relevant_bindings;
1121
1122 (* applying the rule *)
1123 (match r.ruletype with
1124 Ast_cocci.Normal ->
1125 let children_e = ref [] in
1126
1127 (* looping over the functions and toplevel elements in
1128 .c and .h *)
1129 concat_headers_and_c !ccs +> List.iter (fun (c,f) ->
1130 if c.flow <> None
1131 then
1132 (* does also some side effects on c and r *)
1133 let processed =
1134 process_a_ctl_a_env_a_toplevel r
1135 relevant_bindings c f in
1136 match processed with
1137 | None -> ()
1138 | Some newbindings ->
1139 newbindings +> List.iter (fun newbinding ->
1140 children_e :=
1141 Common.insert_set newbinding !children_e)
1142 ); (* end iter cs *)
1143
1144 !children_e
1145 | Ast_cocci.Generated ->
1146 process_a_generated_a_env_a_toplevel r
1147 relevant_bindings !ccs;
1148 []) in
1149
1150 let old_bindings_to_keep =
1151 Common.nub
1152 (e +> List.filter (fun (s,v) -> List.mem s r.used_after)) in
1153 let new_e =
1154 if null new_bindings
1155 then
1156 begin
1157 (*use the old bindings, specialized to the used_after_list*)
1158 if !Flag_ctl.partial_match
1159 then
1160 printf
1161 "Empty list of bindings, I will restart from old env";
1162 [(old_bindings_to_keep,rules_that_have_matched)]
1163 end
1164 else
1165 (* combine the new bindings with the old ones, and
1166 specialize to the used_after_list *)
1167 let old_variables = List.map fst old_bindings_to_keep in
1168 (* have to explicitly discard the inherited variables
1169 because we want the inherited value of the positions
1170 variables not the extended one created by
1171 reassociate_positions. want to reassociate freshly
1172 according to the free variables of each rule. *)
1173 let new_bindings_to_add =
1174 Common.nub
1175 (new_bindings +>
1176 List.map
1177 (List.filter
1178 (fun (s,v) ->
1179 List.mem s r.used_after &&
1180 not (List.mem s old_variables)))) in
1181 List.map
1182 (function new_binding_to_add ->
1183 (List.sort compare
1184 (Common.union_set
1185 old_bindings_to_keep new_binding_to_add),
1186 r.rulename::rules_that_have_matched))
1187 new_bindings_to_add in
1188 ((relevant_bindings,new_bindings)::cache,
1189 merge_env new_e newes))
1190 ([],[]) reorganized_env in (* end iter es *)
1191 if !(r.was_matched)
1192 then Common.push2 r.rulename rules_that_have_ever_matched;
1193
1194 es := newes;
1195
1196 (* apply the tagged modifs and reparse *)
1197 if not !Flag.sgrep_mode2
1198 then ccs := rebuild_info_c_and_headers !ccs r.isexp)
1199
1200 and reassociate_positions free_vars negated_pos_vars envs =
1201 (* issues: isolate the bindings that are relevant to a given rule.
1202 separate out the position variables
1203 associate all of the position variables for a given set of relevant
1204 normal variable bindings with each set of relevant normal variable
1205 bindings. Goal: if eg if@p (E) matches in two places, then both inherited
1206 occurrences of E should see both bindings of p, not just its own.
1207 Otherwise, a position constraint for something that matches in two
1208 places will never be useful, because the position can always be
1209 different from the other one. *)
1210 let relevant =
1211 List.map
1212 (function (e,_) ->
1213 List.filter (function (x,_) -> List.mem x free_vars) e)
1214 envs in
1215 let splitted_relevant =
1216 (* separate the relevant variables into the non-position ones and the
1217 position ones *)
1218 List.map
1219 (function r ->
1220 List.fold_left
1221 (function (non_pos,pos) ->
1222 function (v,_) as x ->
1223 if List.mem v negated_pos_vars
1224 then (non_pos,x::pos)
1225 else (x::non_pos,pos))
1226 ([],[]) r)
1227 relevant in
1228 let splitted_relevant =
1229 List.map
1230 (function (non_pos,pos) ->
1231 (List.sort compare non_pos,List.sort compare pos))
1232 splitted_relevant in
1233 let non_poss =
1234 List.fold_left
1235 (function non_pos ->
1236 function (np,_) ->
1237 if List.mem np non_pos then non_pos else np::non_pos)
1238 [] splitted_relevant in
1239 let extended_relevant =
1240 (* extend the position variables with the values found at other identical
1241 variable bindings *)
1242 List.map
1243 (function non_pos ->
1244 let others =
1245 List.filter
1246 (function (other_non_pos,other_pos) ->
1247 (* do we want equal? or just somehow compatible? eg non_pos
1248 binds only E, but other_non_pos binds both E and E1 *)
1249 non_pos =*= other_non_pos)
1250 splitted_relevant in
1251 (non_pos,
1252 List.sort compare
1253 (non_pos @
1254 (combine_pos negated_pos_vars
1255 (List.map (function (_,x) -> x) others)))))
1256 non_poss in
1257 List.combine envs
1258 (List.map (function (non_pos,_) -> List.assoc non_pos extended_relevant)
1259 splitted_relevant)
1260
1261 and combine_pos negated_pos_vars others =
1262 List.map
1263 (function posvar ->
1264 (posvar,
1265 Ast_c.MetaPosValList
1266 (List.sort compare
1267 (List.fold_left
1268 (function positions ->
1269 function other_list ->
1270 try
1271 match List.assoc posvar other_list with
1272 Ast_c.MetaPosValList l1 ->
1273 Common.union_set l1 positions
1274 | _ -> failwith "bad value for a position variable"
1275 with Not_found -> positions)
1276 [] others))))
1277 negated_pos_vars
1278
1279 and process_a_generated_a_env_a_toplevel2 r env = function
1280 [cfile] ->
1281 let free_vars =
1282 List.filter
1283 (function
1284 (rule,_) when rule =$= r.rulename -> false
1285 | (_,"ARGS") -> false
1286 | _ -> true)
1287 r.free_vars in
1288 let env_domain = List.map (function (nm,vl) -> nm) env in
1289 let metavars =
1290 List.filter
1291 (function md ->
1292 let (rl,_) = Ast_cocci.get_meta_name md in
1293 rl =$= r.rulename)
1294 r.metavars in
1295 if Common.include_set free_vars env_domain
1296 then Unparse_hrule.pp_rule metavars r.ast_rule env cfile.full_fname
1297 | _ -> failwith "multiple files not supported"
1298
1299 and process_a_generated_a_env_a_toplevel rule env ccs =
1300 Common.profile_code "process_a_ctl_a_env_a_toplevel"
1301 (fun () -> process_a_generated_a_env_a_toplevel2 rule env ccs)
1302
1303 (* does side effects on C ast and on Cocci info rule *)
1304 and process_a_ctl_a_env_a_toplevel2 r e c f =
1305 indent_do (fun () ->
1306 show_or_not_celem "trying" c.ast_c;
1307 Flag.currentfile := Some (f ^ ":" ^get_celem c.ast_c);
1308 let (trans_info, returned_any_states, inherited_bindings, newbindings) =
1309 Common.save_excursion Flag_ctl.loop_in_src_code (fun () ->
1310 Flag_ctl.loop_in_src_code := !Flag_ctl.loop_in_src_code||c.contain_loop;
1311
1312 (***************************************)
1313 (* !Main point! The call to the engine *)
1314 (***************************************)
1315 let model_ctl = CCI.model_for_ctl r.dropped_isos (Common.some c.flow) e
1316 in CCI.mysat model_ctl r.ctl (r.used_after, e)
1317 )
1318 in
1319 if not returned_any_states
1320 then None
1321 else begin
1322 show_or_not_celem "found match in" c.ast_c;
1323 show_or_not_trans_info trans_info;
1324 List.iter (show_or_not_binding "out") newbindings;
1325
1326 r.was_matched := true;
1327
1328 if not (null trans_info)
1329 then begin
1330 c.was_modified := true;
1331 try
1332 (* les "more than one var in a decl" et "already tagged token"
1333 * font crasher coccinelle. Si on a 5 fichiers, donc on a 5
1334 * failed. Le try limite le scope des crashes pendant la
1335 * trasformation au fichier concerne. *)
1336
1337 (* modify ast via side effect *)
1338 ignore(Transformation_c.transform r.rulename r.dropped_isos
1339 inherited_bindings trans_info (Common.some c.flow));
1340 with Timeout -> raise Timeout | UnixExit i -> raise (UnixExit i)
1341 end;
1342
1343 Some (List.map (function x -> x@inherited_bindings) newbindings)
1344 end
1345 )
1346
1347 and process_a_ctl_a_env_a_toplevel a b c f=
1348 Common.profile_code "process_a_ctl_a_env_a_toplevel"
1349 (fun () -> process_a_ctl_a_env_a_toplevel2 a b c f)
1350
1351
1352 let rec bigloop2 rs (ccs: file_info list) =
1353 let es = ref [(Ast_c.emptyMetavarsBinding,[])] in
1354 let ccs = ref ccs in
1355 let rules_that_have_ever_matched = ref [] in
1356
1357 (* looping over the rules *)
1358 rs +> List.iter (fun r ->
1359 match r with
1360 InitialScriptRuleCocciInfo r | FinalScriptRuleCocciInfo r -> ()
1361 | ScriptRuleCocciInfo r ->
1362 if !Flag_cocci.show_ctl_text then begin
1363 Common.pr_xxxxxxxxxxxxxxxxx ();
1364 pr ("script: " ^ r.language);
1365 Common.pr_xxxxxxxxxxxxxxxxx ();
1366
1367 adjust_pp_with_indent (fun () ->
1368 Format.force_newline();
1369 let (l,mv,code) = r.scr_ast_rule in
1370 let deps = r.scr_dependencies in
1371 Pretty_print_cocci.unparse
1372 (Ast_cocci.ScriptRule (l,deps,mv,code)));
1373 end;
1374
1375 if !Flag.show_misc then print_endline "RESULT =";
1376
1377 let (_, newes) =
1378 List.fold_left
1379 (function (cache, newes) ->
1380 function (e, rules_that_have_matched) ->
1381 match r.language with
1382 "python" ->
1383 apply_python_rule r cache newes e rules_that_have_matched
1384 rules_that_have_ever_matched
1385 | "test" ->
1386 concat_headers_and_c !ccs +> List.iter (fun (c,_) ->
1387 if c.flow <> None
1388 then
1389 Printf.printf "Flow: %s\r\nFlow!\r\n%!" c.fullstring);
1390 (cache, newes)
1391 | _ ->
1392 Printf.printf "Unknown language: %s\n" r.language;
1393 (cache, newes)
1394 )
1395 ([],[]) !es in
1396
1397 es := newes;
1398 | CocciRuleCocciInfo r ->
1399 apply_cocci_rule r rules_that_have_ever_matched es ccs);
1400
1401 if !Flag.sgrep_mode2
1402 then begin
1403 (* sgrep can lead to code that is not parsable, but we must
1404 * still call rebuild_info_c_and_headers to pretty print the
1405 * action (MINUS), so that later the diff will show what was
1406 * matched by sgrep. But we don't want the parsing error message
1407 * hence the following flag setting. So this code propably
1408 * will generate a NotParsedCorrectly for the matched parts
1409 * and the very final pretty print and diff will work
1410 *)
1411 Flag_parsing_c.verbose_parsing := false;
1412 ccs := rebuild_info_c_and_headers !ccs false
1413 end;
1414 !ccs (* return final C asts *)
1415
1416 let bigloop a b =
1417 Common.profile_code "bigloop" (fun () -> bigloop2 a b)
1418
1419 let initial_final_bigloop2 ty rebuild r =
1420 if !Flag_cocci.show_ctl_text then
1421 begin
1422 Common.pr_xxxxxxxxxxxxxxxxx ();
1423 pr (ty ^ ": " ^ r.language);
1424 Common.pr_xxxxxxxxxxxxxxxxx ();
1425
1426 adjust_pp_with_indent (fun () ->
1427 Format.force_newline();
1428 Pretty_print_cocci.unparse(rebuild r.scr_ast_rule));
1429 end;
1430
1431 match r.language with
1432 "python" ->
1433 (* include_match makes no sense in an initial or final rule, although
1434 er have no way to prevent it *)
1435 let _ = apply_python_rule r [] [] [] [] (ref []) in ()
1436 | _ ->
1437 Printf.printf "Unknown language for initial/final script: %s\n"
1438 r.language
1439
1440 let initial_final_bigloop a b c =
1441 Common.profile_code "initial_final_bigloop"
1442 (fun () -> initial_final_bigloop2 a b c)
1443
1444 (*****************************************************************************)
1445 (* The main functions *)
1446 (*****************************************************************************)
1447
1448 let pre_engine2 (coccifile, isofile) =
1449 show_or_not_cocci coccifile isofile;
1450 Pycocci.set_coccifile coccifile;
1451
1452 let isofile =
1453 if not (Common.lfile_exists isofile)
1454 then begin
1455 pr2 ("warning: Can't find default iso file: " ^ isofile);
1456 None
1457 end
1458 else Some isofile in
1459
1460 (* useful opti when use -dir *)
1461 let (metavars,astcocci,free_var_lists,negated_pos_lists,used_after_lists,
1462 positions_lists,toks,_) =
1463 sp_of_file coccifile isofile in
1464 let ctls = ctls_of_ast astcocci used_after_lists positions_lists in
1465
1466 g_contain_typedmetavar := sp_contain_typed_metavar astcocci;
1467
1468 check_macro_in_sp_and_adjust toks;
1469
1470 show_or_not_ctl_tex astcocci ctls;
1471
1472 let cocci_infos =
1473 prepare_cocci ctls free_var_lists negated_pos_lists
1474 used_after_lists positions_lists metavars astcocci in
1475
1476 let _ =
1477 List.fold_left
1478 (function languages ->
1479 function
1480 InitialScriptRuleCocciInfo(r) ->
1481 (if List.mem r.language languages
1482 then failwith ("double initializer found for "^r.language));
1483 initial_final_bigloop "initial"
1484 (function(x,_,y) -> Ast_cocci.InitialScriptRule(x,y))
1485 r;
1486 r.language::languages
1487 | _ -> languages)
1488 [] cocci_infos in
1489 (cocci_infos,toks)
1490
1491 let pre_engine a =
1492 Common.profile_code "pre_engine" (fun () -> pre_engine2 a)
1493
1494 let full_engine2 (cocci_infos,toks) cfiles =
1495
1496 show_or_not_cfiles cfiles;
1497
1498 (* optimisation allowing to launch coccinelle on all the drivers *)
1499 if !Flag_cocci.worth_trying_opt && not (worth_trying cfiles toks)
1500 then
1501 begin
1502 pr2 ("not worth trying:" ^ Common.join " " cfiles);
1503 cfiles +> List.map (fun s -> s, None)
1504 end
1505 else
1506 begin
1507
1508 if !Flag.show_misc then Common.pr_xxxxxxxxxxxxxxxxx();
1509 if !Flag.show_misc then pr "let's go";
1510 if !Flag.show_misc then Common.pr_xxxxxxxxxxxxxxxxx();
1511
1512 let choose_includes =
1513 match !Flag_cocci.include_options with
1514 Flag_cocci.I_UNSPECIFIED ->
1515 if !g_contain_typedmetavar
1516 then Flag_cocci.I_NORMAL_INCLUDES
1517 else Flag_cocci.I_NO_INCLUDES
1518 | x -> x in
1519 let c_infos = prepare_c cfiles choose_includes in
1520
1521 (* ! the big loop ! *)
1522 let c_infos' = bigloop cocci_infos c_infos in
1523
1524 if !Flag.show_misc then Common.pr_xxxxxxxxxxxxxxxxx ();
1525 if !Flag.show_misc then pr "Finished";
1526 if !Flag.show_misc then Common.pr_xxxxxxxxxxxxxxxxx ();
1527 if !Flag_ctl.graphical_trace then gen_pdf_graph ();
1528
1529 c_infos' +> List.map (fun c_or_h ->
1530 if !(c_or_h.was_modified_once)
1531 then
1532 begin
1533 let outfile =
1534 Common.new_temp_file "cocci-output" ("-" ^ c_or_h.fname) in
1535
1536 if c_or_h.fkind =*= Header
1537 then pr2 ("a header file was modified: " ^ c_or_h.fname);
1538
1539 (* and now unparse everything *)
1540 cfile_of_program (for_unparser c_or_h.asts) outfile;
1541
1542 let show_only_minus = !Flag.sgrep_mode2 in
1543 show_or_not_diff c_or_h.fpath outfile show_only_minus;
1544
1545 (c_or_h.fpath,
1546 if !Flag.sgrep_mode2 then None else Some outfile)
1547 end
1548 else (c_or_h.fpath, None))
1549 end
1550
1551 let full_engine a b =
1552 Common.profile_code "full_engine" (fun () -> full_engine2 a b)
1553
1554 let post_engine2 (cocci_infos,_) =
1555 let _ =
1556 List.fold_left
1557 (function languages ->
1558 function
1559 FinalScriptRuleCocciInfo(r) ->
1560 (if List.mem r.language languages
1561 then failwith ("double finalizer found for "^r.language));
1562 initial_final_bigloop "final"
1563 (function(x,_,y) -> Ast_cocci.FinalScriptRule(x,y))
1564 r;
1565 r.language::languages
1566 | _ -> languages)
1567 [] cocci_infos in
1568 ()
1569
1570 let post_engine a =
1571 Common.profile_code "post_engine" (fun () -> post_engine2 a)
1572
1573 (*****************************************************************************)
1574 (* check duplicate from result of full_engine *)
1575 (*****************************************************************************)
1576
1577 let check_duplicate_modif2 xs =
1578 (* opti: let groups = Common.groupBy (fun (a,resa) (b,resb) -> a =$= b) xs *)
1579 pr2 ("Check duplication for " ^ i_to_s (List.length xs) ^ " files");
1580 let groups = Common.group_assoc_bykey_eff xs in
1581 groups +> Common.map_filter (fun (file, xs) ->
1582 match xs with
1583 | [] -> raise Impossible
1584 | [res] -> Some (file, res)
1585 | res::xs ->
1586 match res with
1587 | None ->
1588 if not (List.for_all (fun res2 -> res2 =*= None) xs)
1589 then begin
1590 pr2 ("different modification result for " ^ file);
1591 None
1592 end
1593 else Some (file, None)
1594 | Some res ->
1595 if not(List.for_all (fun res2 ->
1596 match res2 with
1597 | None -> false
1598 | Some res2 ->
1599 let diff = Common.cmd_to_list ("diff -u -b -B "^res^" "^res2)
1600 in
1601 null diff
1602 ) xs) then begin
1603 pr2 ("different modification result for " ^ file);
1604 None
1605 end
1606 else Some (file, Some res)
1607
1608
1609 )
1610 let check_duplicate_modif a =
1611 Common.profile_code "check_duplicate" (fun () -> check_duplicate_modif2 a)
1612