2 * Copyright 2010, INRIA, University of Copenhagen
3 * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
4 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
5 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
6 * This file is part of Coccinelle.
8 * Coccinelle is free software: you can redistribute it and/or modify
9 * it under the terms of the GNU General Public License as published by
10 * the Free Software Foundation, according to version 2 of the License.
12 * Coccinelle is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 * GNU General Public License for more details.
17 * You should have received a copy of the GNU General Public License
18 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
20 * The authors reserve the right to distribute this or future versions of
21 * Coccinelle under other licenses.
27 module CCI
= Ctlcocci_integration
28 module TAC
= Type_annoter_c
30 module Ast_to_flow
= Control_flow_c_build
32 (*****************************************************************************)
33 (* This file is a kind of driver. It gathers all the important functions
34 * from coccinelle in one place. The different entities in coccinelle are:
38 * - flow (contain nodes)
39 * - ctl (contain rule_elems)
40 * This file contains functions to transform one in another.
42 (*****************************************************************************)
44 (* --------------------------------------------------------------------- *)
46 (* --------------------------------------------------------------------- *)
47 let cprogram_of_file file
=
48 let (program2
, _stat
) = Parse_c.parse_c_and_cpp file
in
51 let cprogram_of_file_cached file
=
52 let (program2
, _stat
) = Parse_c.parse_cache file
in
53 if !Flag_cocci.ifdef_to_if
55 program2
+> Parse_c.with_program2
(fun asts
->
56 Cpp_ast_c.cpp_ifdef_statementize asts
60 let cfile_of_program program2_with_ppmethod outf
=
61 Unparse_c.pp_program program2_with_ppmethod outf
63 (* for memoization, contains only one entry, the one for the SP *)
64 let _hparse = Hashtbl.create
101
65 let _hctl = Hashtbl.create
101
67 (* --------------------------------------------------------------------- *)
69 (* --------------------------------------------------------------------- *)
70 let sp_of_file2 file iso
=
71 Common.memoized
_hparse (file
, iso
) (fun () ->
72 Parse_cocci.process file iso
false)
73 let sp_of_file file iso
=
74 Common.profile_code
"parse cocci" (fun () -> sp_of_file2 file iso
)
77 (* --------------------------------------------------------------------- *)
79 (* --------------------------------------------------------------------- *)
81 Ograph_extended.print_ograph_mutable flow
"/tmp/test.dot" true
84 let ast_to_flow_with_error_messages2 x
=
86 try Ast_to_flow.ast_to_control_flow x
87 with Ast_to_flow.Error x
->
88 Ast_to_flow.report_error x
;
91 flowopt +> do_option
(fun flow
->
92 (* This time even if there is a deadcode, we still have a
93 * flow graph, so I can try the transformation and hope the
94 * deadcode will not bother us.
96 try Ast_to_flow.deadcode_detection flow
97 with Ast_to_flow.Error
(Ast_to_flow.DeadCode x
) ->
98 Ast_to_flow.report_error
(Ast_to_flow.DeadCode x
);
101 let ast_to_flow_with_error_messages a
=
102 Common.profile_code
"flow" (fun () -> ast_to_flow_with_error_messages2 a
)
105 (* --------------------------------------------------------------------- *)
107 (* --------------------------------------------------------------------- *)
109 let ctls_of_ast2 ast
(ua
,fua
,fuas
) pos
=
111 (function ast
-> function (ua
,(fua
,(fuas
,pos
))) ->
115 else Asttoctl2.asttoctl ast
(ua
,fua
,fuas
) pos
)
116 (Asttomember.asttomember ast ua
))
117 ast
(List.combine ua
(List.combine fua
(List.combine fuas pos
)))
119 let ctls_of_ast ast ua
=
120 Common.profile_code
"asttoctl2" (fun () -> ctls_of_ast2 ast ua
)
122 (*****************************************************************************)
123 (* Some debugging functions *)
124 (*****************************************************************************)
128 let show_or_not_cfile2 cfile
=
129 if !Flag_cocci.show_c
then begin
130 Common.pr2_xxxxxxxxxxxxxxxxx
();
131 pr2
("processing C file: " ^ cfile
);
132 Common.pr2_xxxxxxxxxxxxxxxxx
();
133 Common.command2
("cat " ^ cfile
);
135 let show_or_not_cfile a
=
136 Common.profile_code
"show_xxx" (fun () -> show_or_not_cfile2 a
)
138 let show_or_not_cfiles cfiles
= List.iter
show_or_not_cfile cfiles
141 let show_or_not_cocci2 coccifile isofile
=
142 if !Flag_cocci.show_cocci
then begin
143 Common.pr2_xxxxxxxxxxxxxxxxx
();
144 pr2
("processing semantic patch file: " ^ coccifile
);
145 isofile
+> (fun s
-> pr2
("with isos from: " ^ s
));
146 Common.pr2_xxxxxxxxxxxxxxxxx
();
147 Common.command2
("cat " ^ coccifile
);
150 let show_or_not_cocci a b
=
151 Common.profile_code
"show_xxx" (fun () -> show_or_not_cocci2 a b
)
153 (* ---------------------------------------------------------------------- *)
156 let fix_sgrep_diffs l
=
158 List.filter
(function s
-> (s
=~
"^\\+\\+\\+") || not
(s
=~
"^\\+")) l in
159 let l = List.rev
l in
160 (* adjust second number for + code *)
161 let rec loop1 n
= function
164 if s
=~
"^-" && not
(s
=~
"^---")
165 then s
:: loop1 (n
+1) ss
168 (match Str.split
(Str.regexp
" ") s
with
170 (match Str.split
(Str.regexp
",") pl
with
172 let n2 = int_of_string
n2 in
173 (Printf.sprintf
"%s %s %s,%d %s" bef min n1
(n2-n
)
174 (String.concat
" " aft
))
176 | _
-> failwith
"bad + line information")
177 | _
-> failwith
"bad @@ information")
178 else s
:: loop1 n ss
in
179 let rec loop2 n
= function
186 (match Str.split
(Str.regexp
" ") s
with
188 (match (Str.split
(Str.regexp
",") min
,
189 Str.split
(Str.regexp
",") pl
) with
193 (String.sub
n1 1 ((String.length
n1)-1)) in
194 let m2 = int_of_string
m2 in
195 let n2 = int_of_string
n2 in
196 (Printf.sprintf
"%s %s +%d,%d %s" bef min
(n1-n
) n2
197 (String.concat
" " aft
))
198 :: loop2 (n
+(m2-n2)) ss
199 | _
-> failwith
"bad -/+ line information")
200 | _
-> failwith
"bad @@ information")
201 else s
:: loop2 n ss
in
202 loop2 0 (List.rev
(loop1 0 l))
204 let normalize_path file
=
206 if String.get file
0 = '
/'
then file
else (Sys.getcwd
()) ^
"/" ^ file
in
207 let elements = Str.split_delim
(Str.regexp
"/") fullpath in
208 let rec loop prev
= function
209 [] -> String.concat
"/" (List.rev prev
)
210 | "." :: rest
-> loop prev rest
213 x
::xs
-> loop xs rest
214 | _
-> failwith
"bad path")
215 | x
::rest
-> loop (x
::prev
) rest
in
218 let show_or_not_diff2 cfile outfile
=
219 if !Flag_cocci.show_diff
then begin
220 match Common.fst
(Compare_c.compare_to_original cfile outfile
) with
221 Compare_c.Correct
-> () (* diff only in spacing, etc *)
223 (* may need --strip-trailing-cr under windows *)
227 match !Flag_parsing_c.diff_lines
with
228 | None
-> "diff -u -p " ^ cfile ^
" " ^ outfile
229 | Some n
-> "diff -U "^n^
" -p "^cfile^
" "^outfile
in
231 let res = Common.cmd_to_list
line in
232 match (!Flag.patch
,res) with
233 (* create something that looks like the output of patch *)
234 (Some prefix
,minus_file
::plus_file
::rest
) ->
236 let lp = String.length
prefix in
237 if String.get
prefix (lp-1) = '
/'
238 then String.sub
prefix 0 (lp-1)
240 let drop_prefix file
=
241 let file = normalize_path file in
242 if Str.string_match
(Str.regexp
prefix) file 0
244 let lp = String.length
prefix in
245 let lf = String.length
file in
247 then String.sub
file lp (lf - lp)
250 (Printf.sprintf
"prefix %s doesn't match file %s"
254 (Printf.sprintf
"prefix %s doesn't match file %s"
257 match List.rev
(Str.split
(Str.regexp
" ") line) with
258 new_file
::old_file
::cmdrev
->
262 (List.rev
("/tmp/nothing" :: old_file
:: cmdrev
))
264 let old_base_file = drop_prefix old_file
in
267 (("b"^
old_base_file)::("a"^
old_base_file)::cmdrev
))
268 | _
-> failwith
"bad command" in
269 let (minus_line
,plus_line
) =
271 then (minus_file
,"+++ /tmp/nothing")
273 match (Str.split
(Str.regexp
"[ \t]") minus_file
,
274 Str.split
(Str.regexp
"[ \t]") plus_file
) with
275 ("---"::old_file
::old_rest
,"+++"::new_file
::new_rest
) ->
276 let old_base_file = drop_prefix old_file
in
278 ("---"::("a"^
old_base_file)::old_rest
),
280 ("+++"::("b"^
old_base_file)::new_rest
))
283 (Printf.sprintf
"bad diff header lines: %s %s"
284 (String.concat
":" l1
) (String.concat
":" l2
)) in
285 diff_line::minus_line
::plus_line
::rest
287 let xs = if !Flag.sgrep_mode2
then fix_sgrep_diffs xs else xs in
290 let show_or_not_diff a b
=
291 Common.profile_code
"show_xxx" (fun () -> show_or_not_diff2 a b
)
294 (* the derived input *)
296 let show_or_not_ctl_tex2 astcocci ctls
=
297 if !Flag_cocci.show_ctl_tex
then begin
298 Ctltotex.totex
("/tmp/__cocci_ctl.tex") astcocci ctls
;
299 Common.command2
("cd /tmp; latex __cocci_ctl.tex; " ^
300 "dvips __cocci_ctl.dvi -o __cocci_ctl.ps;" ^
301 "gv __cocci_ctl.ps &");
303 let show_or_not_ctl_tex a b
=
304 Common.profile_code
"show_xxx" (fun () -> show_or_not_ctl_tex2 a b
)
307 let show_or_not_rule_name ast rulenb
=
308 if !Flag_cocci.show_ctl_text
or !Flag.show_trying
or
309 !Flag.show_transinfo
or !Flag_cocci.show_binding_in_out
314 Ast_cocci.CocciRule
(nm
, (deps
, drops
, exists
), x
, _
, _
) -> nm
315 | _
-> i_to_s rulenb
in
316 Common.pr_xxxxxxxxxxxxxxxxx
();
318 Common.pr_xxxxxxxxxxxxxxxxx
()
321 let show_or_not_scr_rule_name rulenb
=
322 if !Flag_cocci.show_ctl_text
or !Flag.show_trying
or
323 !Flag.show_transinfo
or !Flag_cocci.show_binding_in_out
326 let name = i_to_s rulenb
in
327 Common.pr_xxxxxxxxxxxxxxxxx
();
328 pr
("script rule " ^
name ^
" = ");
329 Common.pr_xxxxxxxxxxxxxxxxx
()
332 let show_or_not_ctl_text2 ctl ast rulenb
=
333 if !Flag_cocci.show_ctl_text
then begin
335 adjust_pp_with_indent
(fun () ->
336 Format.force_newline
();
337 Pretty_print_cocci.print_plus_flag
:= true;
338 Pretty_print_cocci.print_minus_flag
:= true;
339 Pretty_print_cocci.unparse ast
;
344 adjust_pp_with_indent
(fun () ->
345 Format.force_newline
();
346 Pretty_print_engine.pp_ctlcocci
347 !Flag_cocci.show_mcodekind_in_ctl
!Flag_cocci.inline_let_ctl ctl
;
351 let show_or_not_ctl_text a b c
=
352 Common.profile_code
"show_xxx" (fun () -> show_or_not_ctl_text2 a b c
)
356 (* running information *)
357 let get_celem celem
: string =
359 Ast_c.Definition
({Ast_c.f_name
= namefuncs
;},_
) ->
360 Ast_c.str_of_name namefuncs
362 (Ast_c.DeclList
([{Ast_c.v_namei
= Some
(name, _
);}, _
], _
)) ->
363 Ast_c.str_of_name
name
366 let show_or_not_celem2 prelude celem
=
369 | Ast_c.Definition
({Ast_c.f_name
= namefuncs
},_
) ->
370 let funcs = Ast_c.str_of_name namefuncs
in
371 Flag.current_element
:= funcs;
372 (" function: ",funcs)
374 (Ast_c.DeclList
([{Ast_c.v_namei
= Some
(name,_
)}, _
], _
)) ->
375 let s = Ast_c.str_of_name
name in
376 Flag.current_element
:= s;
379 Flag.current_element
:= "something_else";
380 (" ","something else");
382 if !Flag.show_trying
then pr2
(prelude ^ tag ^ trying
)
384 let show_or_not_celem a b
=
385 Common.profile_code
"show_xxx" (fun () -> show_or_not_celem2 a b
)
388 let show_or_not_trans_info2 trans_info
=
389 (* drop witness tree indices for printing *)
391 List.map
(function (index
,trans_info) -> trans_info) trans_info in
392 if !Flag.show_transinfo
then begin
393 if null
trans_info then pr2
"transformation info is empty"
395 pr2
"transformation info returned:";
397 List.sort
(function (i1
,_
,_
) -> function (i2
,_
,_
) -> compare i1 i2
)
401 trans_info +> List.iter
(fun (i
, subst
, re
) ->
402 pr2
("transform state: " ^
(Common.i_to_s i
));
404 adjust_pp_with_indent_and_header
"with rule_elem: " (fun () ->
405 Pretty_print_cocci.print_plus_flag
:= true;
406 Pretty_print_cocci.print_minus_flag
:= true;
407 Pretty_print_cocci.rule_elem
"" re
;
409 adjust_pp_with_indent_and_header
"with binding: " (fun () ->
410 Pretty_print_engine.pp_binding subst
;
417 let show_or_not_trans_info a
=
418 Common.profile_code
"show_xxx" (fun () -> show_or_not_trans_info2 a
)
422 let show_or_not_binding2 s binding
=
423 if !Flag_cocci.show_binding_in_out
then begin
424 adjust_pp_with_indent_and_header
("binding " ^
s ^
" = ") (fun () ->
425 Pretty_print_engine.pp_binding binding
428 let show_or_not_binding a b
=
429 Common.profile_code
"show_xxx" (fun () -> show_or_not_binding2 a b
)
433 (*****************************************************************************)
434 (* Some helper functions *)
435 (*****************************************************************************)
437 let worth_trying cfiles tokens
=
438 (* drop the following line for a list of list by rules. since we don't
439 allow multiple minirules, all the tokens within a rule should be in
440 a single CFG entity *)
441 match (!Flag_cocci.windows
,tokens
) with
442 (true,_
) | (_
,None
) -> true
444 (* could also modify the code in get_constants.ml *)
445 let tokens = tokens +> List.map
(fun s ->
447 | _
when s =~
"^[A-Za-z_][A-Za-z_0-9]*$" ->
450 | _
when s =~
"^[A-Za-z_]" ->
453 | _
when s =~
".*[A-Za-z_]$" ->
458 let com = sprintf
"egrep -q '(%s)' %s" (join
"|" tokens) (join
" " cfiles
)
460 (match Sys.command
com with
461 | 0 (* success *) -> true
464 then Printf.printf
"grep failed: %s\n" com);
465 false (* no match, so not worth trying *))
467 let check_macro_in_sp_and_adjust = function
470 tokens +> List.iter
(fun s ->
471 if Hashtbl.mem
!Parse_c._defs
s
473 if !Flag_cocci.verbose_cocci
then begin
474 pr2
"warning: macro in semantic patch was in macro definitions";
475 pr2
("disabling macro expansion for " ^
s);
477 Hashtbl.remove
!Parse_c._defs
s
481 let contain_loop gopt
=
484 g#nodes#tolist
+> List.exists
(fun (xi
, node
) ->
485 Control_flow_c.extract_is_loop node
487 | None
-> true (* means nothing, if no g then will not model check *)
491 let sp_contain_typed_metavar_z toplevel_list_list
=
492 let bind x y
= x
or y
in
493 let option_default = false in
494 let mcode _ _
= option_default in
495 let donothing r k e
= k e
in
497 let expression r k e
=
498 match Ast_cocci.unwrap e
with
499 | Ast_cocci.MetaExpr
(_
,_
,_
,Some t
,_
,_
) -> true
500 | Ast_cocci.MetaExpr
(_
,_
,_
,_
,Ast_cocci.LocalID
,_
) -> true
505 Visitor_ast.combiner bind option_default
506 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
507 donothing donothing donothing donothing
508 donothing expression donothing donothing donothing donothing donothing
509 donothing donothing donothing donothing donothing
511 toplevel_list_list
+>
513 (function (nm
,_
,rule
) ->
514 (List.exists
combiner.Visitor_ast.combiner_top_level rule
))
516 let sp_contain_typed_metavar rules
=
517 sp_contain_typed_metavar_z
521 Ast_cocci.CocciRule
(a
,b
,c
,d
,_
) -> (a
,b
,c
)
522 | _
-> failwith
"error in filter")
526 Ast_cocci.CocciRule
(a
,b
,c
,d
,Ast_cocci.Normal
) -> true
532 (* finding among the #include the one that we need to parse
533 * because they may contain useful type definition or because
534 * we may have to modify them
536 * For the moment we base in part our heuristic on the name of the file, e.g.
537 * serio.c is related we think to #include <linux/serio.h>
539 let rec search_include_path searchlist relpath
=
540 match searchlist
with
543 let file = Filename.concat hd relpath
in
544 if Sys.file_exists
file then
547 search_include_path tail relpath
549 let interpret_include_path relpath
=
551 match !Flag_cocci.include_path
with
555 search_include_path searchlist relpath
557 let (includes_to_parse
:
558 (Common.filename
* Parse_c.program2
) list
->
559 Flag_cocci.include_options
-> 'a
) = fun xs choose_includes
->
560 match choose_includes
with
561 Flag_cocci.I_UNSPECIFIED
-> failwith
"not possible"
562 | Flag_cocci.I_NO_INCLUDES
-> []
564 let all_includes = x
=*= Flag_cocci.I_ALL_INCLUDES
in
565 xs +> List.map
(fun (file, cs
) ->
566 let dir = Common.dirname
file in
568 cs
+> Common.map_filter
(fun (c
,_info_item
) ->
572 {Ast_c.i_include
= ((x
,ii
)); i_rel_pos
= info_h_pos
;}) ->
575 let relpath = Common.join
"/" xs in
576 let f = Filename.concat
dir (relpath) in
577 (* for our tests, all the files are flat in the current dir *)
578 if not
(Sys.file_exists
f) && !Flag_cocci.relax_include_path
580 let attempt2 = Filename.concat
dir (Common.last
xs) in
581 if not
(Sys.file_exists
f) && all_includes
583 interpret_include_path relpath
587 | Ast_c.NonLocal
xs ->
588 let relpath = Common.join
"/" xs in
590 Common.fileprefix
(Common.last
xs) =$
= Common.fileprefix
file
592 interpret_include_path relpath
594 | Ast_c.Weird _
-> None
600 let rec interpret_dependencies local global
= function
601 Ast_cocci.Dep
s -> List.mem
s local
602 | Ast_cocci.AntiDep
s ->
603 (if !Flag_ctl.steps
!= None
604 then failwith
"steps and ! dependency incompatible");
605 not
(List.mem
s local
)
606 | Ast_cocci.EverDep
s -> List.mem
s global
607 | Ast_cocci.NeverDep
s ->
608 (if !Flag_ctl.steps
!= None
609 then failwith
"steps and ! dependency incompatible");
610 not
(List.mem
s global
)
611 | Ast_cocci.AndDep
(s1
,s2
) ->
612 (interpret_dependencies local global s1
) &&
613 (interpret_dependencies local global s2
)
614 | Ast_cocci.OrDep
(s1
,s2
) ->
615 (interpret_dependencies local global s1
) or
616 (interpret_dependencies local global s2
)
617 | Ast_cocci.NoDep
-> true
618 | Ast_cocci.FailDep
-> false
620 let rec print_dependencies str local global dep
=
621 if !Flag_cocci.show_dependencies
626 let rec loop = function
627 Ast_cocci.Dep
s | Ast_cocci.AntiDep
s ->
628 if not
(List.mem
s !seen)
632 then pr2
(s^
" satisfied")
633 else pr2
(s^
" not satisfied");
636 | Ast_cocci.EverDep
s | Ast_cocci.NeverDep
s ->
637 if not
(List.mem
s !seen)
641 then pr2
(s^
" satisfied")
642 else pr2
(s^
" not satisfied");
645 | Ast_cocci.AndDep
(s1
,s2
) ->
648 | Ast_cocci.OrDep
(s1
,s2
) ->
651 | Ast_cocci.NoDep
-> ()
652 | Ast_cocci.FailDep
-> pr2
"False not satisfied" in
656 (* --------------------------------------------------------------------- *)
657 (* #include relative position in the file *)
658 (* --------------------------------------------------------------------- *)
660 (* compute the set of new prefixes
662 * "a/b/x"; (* in fact it is now a list of string so ["a";"b";"x"] *)
666 * it would give
for the first element
667 * ""; "a"; "a/b"; "a/b/x"
671 * update
: if the
include is inside a ifdef a put nothing
. cf
-test incl
.
672 * this is because we dont want code added inside ifdef
.
675 let compute_new_prefixes xs =
676 xs +> Common.map_withenv
(fun already
xs ->
677 let subdirs_prefixes = Common.inits
xs in
678 let new_first = subdirs_prefixes +> List.filter
(fun x
->
679 not
(List.mem x already
)
688 (* does via side effect on the ref in the Include in Ast_c *)
689 let rec update_include_rel_pos cs
=
690 let only_include = cs
+> Common.map_filter
(fun c
->
692 | Ast_c.CppTop
(Ast_c.Include
{Ast_c.i_include
= ((x
,_
));
694 i_is_in_ifdef
= inifdef
}) ->
696 | Ast_c.Weird _
-> None
705 let (locals
, nonlocals
) =
706 only_include +> Common.partition_either
(fun (c
, aref
) ->
708 | Ast_c.Local x
-> Left
(x
, aref
)
709 | Ast_c.NonLocal x
-> Right
(x
, aref
)
710 | Ast_c.Weird x
-> raise Impossible
713 update_rel_pos_bis locals
;
714 update_rel_pos_bis nonlocals
;
716 and update_rel_pos_bis
xs =
717 let xs'
= List.map fst
xs in
718 let the_first = compute_new_prefixes xs'
in
719 let the_last = List.rev
(compute_new_prefixes (List.rev
xs'
)) in
720 let merged = Common.zip
xs (Common.zip
the_first the_last) in
721 merged +> List.iter
(fun ((x
, aref
), (the_first, the_last)) ->
724 Ast_c.first_of
= the_first;
725 Ast_c.last_of
= the_last;
730 (*****************************************************************************)
731 (* All the information needed around the C elements and Cocci rules *)
732 (*****************************************************************************)
734 type toplevel_c_info
= {
735 ast_c
: Ast_c.toplevel
; (* contain refs so can be modified *)
736 tokens_c
: Parser_c.token list
;
739 flow
: Control_flow_c.cflow
option; (* it's the "fixed" flow *)
742 env_typing_before
: TAC.environment
;
743 env_typing_after
: TAC.environment
;
745 was_modified
: bool ref;
750 type toplevel_cocci_info_script_rule
= {
751 scr_ast_rule
: string * (string * Ast_cocci.meta_name
) list
* string;
753 scr_dependencies
: Ast_cocci.dependency
;
758 type toplevel_cocci_info_cocci_rule
= {
759 ctl
: Lib_engine.ctlcocci
* (CCI.pred list list
);
760 metavars
: Ast_cocci.metavar list
;
761 ast_rule
: Ast_cocci.rule
;
762 isexp
: bool; (* true if + code is an exp, only for Flag.make_hrule *)
765 dependencies
: Ast_cocci.dependency
;
766 (* There are also some hardcoded rule names in parse_cocci.ml:
767 * let reserved_names = ["all";"optional_storage";"optional_qualifier"]
769 dropped_isos
: string list
;
770 free_vars
: Ast_cocci.meta_name list
;
771 negated_pos_vars
: Ast_cocci.meta_name list
;
772 used_after
: Ast_cocci.meta_name list
;
773 positions
: Ast_cocci.meta_name list
;
776 ruletype
: Ast_cocci.ruletype
;
778 was_matched
: bool ref;
781 type toplevel_cocci_info
=
782 ScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
783 | InitialScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
784 | FinalScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
785 | CocciRuleCocciInfo
of toplevel_cocci_info_cocci_rule
787 type cocci_info
= toplevel_cocci_info list
* string list
option (* tokens *)
789 type kind_file
= Header
| Source
793 was_modified_once
: bool ref;
794 asts
: toplevel_c_info list
;
799 let g_contain_typedmetavar = ref false
802 let last_env_toplevel_c_info xs =
803 (Common.last
xs).env_typing_after
805 let concat_headers_and_c (ccs
: file_info list
)
806 : (toplevel_c_info
* string) list
=
807 (List.concat
(ccs
+> List.map
(fun x
->
808 x
.asts
+> List.map
(fun x'
->
811 let for_unparser xs =
812 xs +> List.map
(fun x
->
813 (x
.ast_c
, (x
.fullstring
, x
.tokens_c
)), Unparse_c.PPviastr
816 let gen_pdf_graph () =
817 (Ctl_engine.get_graph_files
()) +> List.iter
(fun outfile
->
818 Printf.printf
"Generation of %s%!" outfile
;
819 let filename_stack = Ctl_engine.get_graph_comp_files outfile
in
820 List.iter
(fun filename
->
821 ignore
(Unix.system
("dot " ^ filename ^
" -Tpdf -o " ^ filename ^
".pdf;"))
823 let (head
,tail
) = (List.hd
filename_stack, List.tl
filename_stack) in
824 ignore
(Unix.system
("cp " ^ head ^
".pdf " ^ outfile ^
".pdf;"));
825 tail
+> List.iter
(fun filename
->
826 ignore
(Unix.system
("mv " ^ outfile ^
".pdf /tmp/tmp.pdf;"));
827 ignore
(Unix.system
("pdftk " ^ filename ^
".pdf /tmp/tmp.pdf cat output " ^ outfile ^
".pdf"));
829 ignore
(Unix.system
("rm /tmp/tmp.pdf;"));
830 List.iter
(fun filename
->
831 ignore
(Unix.system
("rm " ^ filename ^
" " ^ filename ^
".pdf;"))
833 Printf.printf
" - Done\n")
835 let local_python_code =
836 "from coccinelle import *\n"
839 "import coccinelle\n"^
841 "import coccilib.org\n"^
842 "import coccilib.report\n" ^
846 let make_init rulenb lang deps code
=
849 scr_ast_rule
= (lang
, mv, code
);
851 scr_dependencies
= deps
;
853 script_code
= (if lang
= "python" then python_code else "") ^code
856 (* --------------------------------------------------------------------- *)
857 let prepare_cocci ctls free_var_lists negated_pos_lists
858 (ua
,fua
,fuas
) positions_list metavars astcocci
=
860 let gathered = Common.index_list_1
861 (zip
(zip
(zip
(zip
(zip
(zip
(zip
(zip ctls metavars
) astcocci
)
863 negated_pos_lists
) ua
) fua
) fuas
) positions_list
)
866 (fun (((((((((ctl_toplevel_list
,metavars
),ast
),free_var_list
),
867 negated_pos_list
),ua
),fua
),fuas
),positions_list
),rulenb
) ->
869 let is_script_rule r
=
871 Ast_cocci.ScriptRule _
872 | Ast_cocci.InitialScriptRule _
| Ast_cocci.FinalScriptRule _
-> true
875 if not
(List.length ctl_toplevel_list
=|= 1) && not
(is_script_rule ast
)
876 then failwith
"not handling multiple minirules";
879 Ast_cocci.ScriptRule
(lang
,deps
,mv,code
) ->
882 scr_ast_rule
= (lang
, mv, code
);
884 scr_dependencies
= deps
;
888 in ScriptRuleCocciInfo
r
889 | Ast_cocci.InitialScriptRule
(lang
,deps
,code
) ->
890 let r = make_init rulenb lang deps code
in
891 InitialScriptRuleCocciInfo
r
892 | Ast_cocci.FinalScriptRule
(lang
,deps
,code
) ->
896 scr_ast_rule
= (lang
, mv, code
);
898 scr_dependencies
= deps
;
902 in FinalScriptRuleCocciInfo
r
903 | Ast_cocci.CocciRule
904 (rulename
,(dependencies
,dropped_isos
,z
),restast
,isexp
,ruletype
) ->
907 ctl
= List.hd ctl_toplevel_list
;
910 isexp
= List.hd isexp
;
912 dependencies
= dependencies
;
913 dropped_isos
= dropped_isos
;
914 free_vars
= List.hd free_var_list
;
915 negated_pos_vars
= List.hd negated_pos_list
;
916 used_after
= (List.hd ua
) @ (List.hd fua
);
917 positions
= List.hd positions_list
;
920 was_matched
= ref false;
925 (* --------------------------------------------------------------------- *)
927 let build_info_program cprogram env
=
929 let (cs
, parseinfos
) =
930 Common.unzip cprogram
in
933 parseinfos
+> List.map
(fun (s,toks
) -> toks
) +> List.flatten
in
935 (* I use cs' but really annotate_xxx work by doing side effects on cs *)
937 Comment_annotater_c.annotate_program
alltoks cs in
939 Type_annoter_c.annotate_program env
(*!g_contain_typedmetavar*) cs'
942 zip
cs_with_envs parseinfos
+> List.map
(fun ((c
, (enva
,envb
)), parseinfo
)->
943 let (fullstr
, tokens) = parseinfo
in
946 ast_to_flow_with_error_messages c
+>
947 Common.map_option
(fun flow ->
948 let flow = Ast_to_flow.annotate_loop_nodes
flow in
950 (* remove the fake nodes for julia *)
951 let fixed_flow = CCI.fix_flow_ctl
flow in
953 if !Flag_cocci.show_flow
then print_flow fixed_flow;
954 if !Flag_cocci.show_before_fixed_flow
then print_flow flow;
961 ast_c
= c
; (* contain refs so can be modified *)
963 fullstring
= fullstr
;
967 contain_loop = contain_loop flow;
969 env_typing_before
= enva
;
970 env_typing_after
= envb
;
972 was_modified
= ref false;
978 (* Optimisation. Try not unparse/reparse the whole file when have modifs *)
979 let rebuild_info_program cs file isexp
=
980 cs +> List.map
(fun c
->
983 let file = Common.new_temp_file
"cocci_small_output" ".c" in
985 [(c
.ast_c
, (c
.fullstring
, c
.tokens_c
)), Unparse_c.PPnormal
]
988 (* Common.command2 ("cat " ^ file); *)
989 let cprogram = cprogram_of_file file in
990 let xs = build_info_program cprogram c
.env_typing_before
in
992 (* TODO: assert env has not changed,
993 * if yes then must also reparse what follows even if not modified.
994 * Do that only if contain_typedmetavar of course, so good opti.
996 (* Common.list_init xs *) (* get rid of the FinalDef *)
1002 let rebuild_info_c_and_headers ccs isexp
=
1003 ccs
+> List.iter
(fun c_or_h
->
1004 if c_or_h
.asts
+> List.exists
(fun c
-> !(c
.was_modified
))
1005 then c_or_h
.was_modified_once
:= true;
1007 ccs
+> List.map
(fun c_or_h
->
1010 rebuild_info_program c_or_h
.asts c_or_h
.full_fname isexp
}
1015 let prepare_c files choose_includes
: file_info list
=
1016 let cprograms = List.map
cprogram_of_file_cached files
in
1017 let includes = includes_to_parse
(zip files
cprograms) choose_includes
in
1019 (* todo?: may not be good to first have all the headers and then all the c *)
1021 (includes +> List.map
(fun hpath
-> Right hpath
))
1023 ((zip files
cprograms) +>
1024 List.map
(fun (file, asts
) -> Left
(file, asts
)))
1027 let env = ref !TAC.initial_env
in
1029 let ccs = all +> Common.map_filter
(fun x
->
1032 if not
(Common.lfile_exists hpath
)
1034 pr2
("TYPE: header " ^ hpath ^
" not found");
1038 let h_cs = cprogram_of_file_cached hpath
in
1039 let info_h_cs = build_info_program h_cs !env in
1043 else last_env_toplevel_c_info info_h_cs
1046 fname
= Common.basename hpath
;
1049 was_modified_once
= ref false;
1053 | Left
(file, cprogram) ->
1054 (* todo?: don't update env ? *)
1055 let cs = build_info_program cprogram !env in
1056 (* we do that only for the c, not for the h *)
1057 ignore
(update_include_rel_pos (cs +> List.map
(fun x
-> x
.ast_c
)));
1059 fname
= Common.basename
file;
1062 was_modified_once
= ref false;
1071 (*****************************************************************************)
1072 (* Processing the ctls and toplevel C elements *)
1073 (*****************************************************************************)
1075 (* The main algorithm =~
1076 * The algorithm is roughly:
1077 * for_all ctl rules in SP
1078 * for_all minirule in rule (no more)
1079 * for_all binding (computed during previous phase)
1080 * for_all C elements
1081 * match control flow of function vs minirule
1082 * with the binding and update the set of possible
1083 * bindings, and returned the possibly modified function.
1084 * pretty print modified C elements and reparse it.
1087 * On ne prends que les newbinding ou returned_any_state est vrai.
1088 * Si ca ne donne rien, on prends ce qu'il y avait au depart.
1089 * Mais au nouveau depart de quoi ?
1090 * - si ca donne rien apres avoir traité toutes les fonctions avec ce binding ?
1091 * - ou alors si ca donne rien, apres avoir traité toutes les fonctions
1092 * avec tous les bindings du round d'avant ?
1094 * Julia pense qu'il faut prendre la premiere solution.
1095 * Example: on a deux environnements candidats, E1 et E2 apres avoir traité
1096 * la regle ctl 1. On arrive sur la regle ctl 2.
1097 * E1 ne donne rien pour la regle 2, on garde quand meme E1 pour la regle 3.
1098 * E2 donne un match a un endroit et rend E2' alors on utilise ca pour
1101 * I have not to look at used_after_list to decide to restart from
1102 * scratch. I just need to look if the binding list is empty.
1103 * Indeed, let's suppose that a SP have 3 regions/rules. If we
1104 * don't find a match for the first region, then if this first
1105 * region does not bind metavariable used after, that is if
1106 * used_after_list is empty, then mysat(), even if does not find a
1107 * match, will return a Left, with an empty transformation_info,
1108 * and so current_binding will grow. On the contrary if the first
1109 * region must bind some metavariables used after, and that we
1110 * dont find any such region, then mysat() will returns lots of
1111 * Right, and current_binding will not grow, and so we will have
1112 * an empty list of binding, and we will catch such a case.
1114 * opti: julia says that because the binding is
1115 * determined by the used_after_list, the items in the list
1116 * are kind of sorted, so could optimise the insert_set operations.
1120 (* r(ule), c(element in C code), e(nvironment) *)
1123 let rec loop k
= function
1127 then Some
(x
, function n
-> k
(n
:: xs))
1128 else loop (function vs
-> k
(x
:: vs
)) xs in
1129 loop (function x
-> x
) l
1131 let merge_env new_e old_e
=
1134 (function (ext
,old_e
) ->
1135 function (e
,rules
) as elem
->
1136 match findk (function (e1
,_
) -> e
=*= e1
) old_e
with
1137 None
-> (elem
:: ext
,old_e
)
1138 | Some
((_
,old_rules
),k
) ->
1139 (ext
,k
(e
,Common.union_set rules old_rules
)))
1141 old_e
@ (List.rev ext
)
1143 let apply_python_rule r cache newes e rules_that_have_matched
1144 rules_that_have_ever_matched
=
1145 Common.profile_code
"python" (fun () ->
1146 show_or_not_scr_rule_name r.scr_ruleid
;
1147 if not
(interpret_dependencies rules_that_have_matched
1148 !rules_that_have_ever_matched
r.scr_dependencies
)
1151 print_dependencies "dependencies for script not satisfied:"
1152 rules_that_have_matched
1153 !rules_that_have_ever_matched
r.scr_dependencies
;
1154 show_or_not_binding "in environment" e
;
1155 (cache
, (e
, rules_that_have_matched
)::newes
)
1159 let (_
, mv, _
) = r.scr_ast_rule
in
1161 (List.map
(function (n
,v
) -> (("virtual",n
),Ast_c.MetaIdVal
(v
,[])))
1162 !Flag.defined_virtual_env
) @ e
in
1163 let not_bound x
= not
(Pycocci.contains_binding
ve x
) in
1164 (match List.filter
not_bound mv with
1166 let relevant_bindings =
1168 (function ((re
,rm
),_
) ->
1169 List.exists
(function (_
,(r,m
)) -> r =*= re
&& m
=$
= rm
) mv)
1172 if List.mem
relevant_bindings cache
1176 "dependencies for script satisfied, but cached:"
1177 rules_that_have_matched
1178 !rules_that_have_ever_matched
1180 show_or_not_binding "in" e
;
1185 print_dependencies "dependencies for script satisfied:"
1186 rules_that_have_matched
1187 !rules_that_have_ever_matched
1189 show_or_not_binding "in" e
;
1190 Pycocci.build_classes
(List.map
(function (x
,y
) -> x
) ve);
1191 Pycocci.construct_variables
mv ve;
1193 Pycocci.pyrun_simplestring
1194 (local_python_code ^
r.script_code
) in
1195 relevant_bindings :: cache
1197 if !Pycocci.inc_match
1198 then (new_cache, merge_env [(e
, rules_that_have_matched
)] newes
)
1199 else (new_cache, newes
)
1201 (if !Flag_cocci.show_dependencies
1203 let m2c (_,(r,x
)) = r^
"."^x
in
1204 pr2
(Printf.sprintf
"script not applied: %s not bound"
1205 (String.concat
", " (List.map
m2c unbound
))));
1206 (cache
, merge_env [(e
, rules_that_have_matched
)] newes
))
1209 let rec apply_cocci_rule r rules_that_have_ever_matched es
1210 (ccs:file_info list
ref) =
1211 Common.profile_code
r.rulename
(fun () ->
1212 show_or_not_rule_name r.ast_rule
r.ruleid
;
1213 show_or_not_ctl_text r.ctl
r.ast_rule
r.ruleid
;
1215 let reorganized_env =
1216 reassociate_positions
r.free_vars
r.negated_pos_vars
!es
in
1218 (* looping over the environments *)
1219 let (_,newes
(* envs for next round/rule *)) =
1221 (function (cache
,newes
) ->
1222 function ((e
,rules_that_have_matched
),relevant_bindings) ->
1223 if not
(interpret_dependencies rules_that_have_matched
1224 !rules_that_have_ever_matched
1229 ("dependencies for rule "^
r.rulename^
" not satisfied:")
1230 rules_that_have_matched
1231 !rules_that_have_ever_matched
r.dependencies
;
1232 show_or_not_binding "in environment" e
;
1235 [(e
+> List.filter
(fun (s,v
) -> List.mem
s r.used_after
),
1236 rules_that_have_matched
)]
1241 try List.assoc
relevant_bindings cache
1245 ("dependencies for rule "^
r.rulename^
" satisfied:")
1246 rules_that_have_matched
1247 !rules_that_have_ever_matched
1249 show_or_not_binding "in" e
;
1250 show_or_not_binding "relevant in" relevant_bindings;
1252 (* applying the rule *)
1253 (match r.ruletype
with
1255 (* looping over the functions and toplevel elements in
1258 (concat_headers_and_c !ccs +>
1259 List.fold_left
(fun children_e
(c
,f) ->
1262 (* does also some side effects on c and r *)
1264 process_a_ctl_a_env_a_toplevel
r
1265 relevant_bindings c
f in
1266 match processed with
1267 | None
-> children_e
1268 | Some newbindings
->
1271 (fun children_e newbinding
->
1272 if List.mem newbinding children_e
1274 else newbinding
:: children_e
)
1278 | Ast_cocci.Generated
->
1279 process_a_generated_a_env_a_toplevel
r
1280 relevant_bindings !ccs;
1283 let old_bindings_to_keep =
1285 (e
+> List.filter
(fun (s,v
) -> List.mem
s r.used_after
)) in
1287 if null
new_bindings
1290 (*use the old bindings, specialized to the used_after_list*)
1291 if !Flag_ctl.partial_match
1294 "Empty list of bindings, I will restart from old env\n";
1295 [(old_bindings_to_keep,rules_that_have_matched
)]
1298 (* combine the new bindings with the old ones, and
1299 specialize to the used_after_list *)
1300 let old_variables = List.map fst
old_bindings_to_keep in
1301 (* have to explicitly discard the inherited variables
1302 because we want the inherited value of the positions
1303 variables not the extended one created by
1304 reassociate_positions. want to reassociate freshly
1305 according to the free variables of each rule. *)
1306 let new_bindings_to_add =
1312 (* see comment before combine_pos *)
1313 (s,Ast_c.MetaPosValList
[]) -> false
1315 List.mem
s r.used_after
&&
1316 not
(List.mem
s old_variables)))) in
1318 (function new_binding_to_add
->
1321 old_bindings_to_keep new_binding_to_add
),
1322 r.rulename
::rules_that_have_matched
))
1323 new_bindings_to_add in
1324 ((relevant_bindings,new_bindings)::cache
,
1325 merge_env new_e newes
))
1326 ([],[]) reorganized_env in (* end iter es *)
1328 then Common.push2
r.rulename rules_that_have_ever_matched
;
1332 (* apply the tagged modifs and reparse *)
1333 if not
!Flag.sgrep_mode2
1334 then ccs := rebuild_info_c_and_headers !ccs r.isexp
)
1336 and reassociate_positions free_vars negated_pos_vars envs
=
1337 (* issues: isolate the bindings that are relevant to a given rule.
1338 separate out the position variables
1339 associate all of the position variables for a given set of relevant
1340 normal variable bindings with each set of relevant normal variable
1341 bindings. Goal: if eg if@p (E) matches in two places, then both inherited
1342 occurrences of E should see both bindings of p, not just its own.
1343 Otherwise, a position constraint for something that matches in two
1344 places will never be useful, because the position can always be
1345 different from the other one. *)
1349 List.filter
(function (x
,_) -> List.mem x free_vars
) e
)
1351 let splitted_relevant =
1352 (* separate the relevant variables into the non-position ones and the
1357 (function (non_pos
,pos
) ->
1358 function (v
,_) as x
->
1359 if List.mem v negated_pos_vars
1360 then (non_pos
,x
::pos
)
1361 else (x
::non_pos
,pos
))
1364 let splitted_relevant =
1366 (function (non_pos
,pos
) ->
1367 (List.sort compare non_pos
,List.sort compare pos
))
1368 splitted_relevant in
1371 (function non_pos
->
1373 if List.mem np non_pos
then non_pos
else np
::non_pos
)
1374 [] splitted_relevant in
1375 let extended_relevant =
1376 (* extend the position variables with the values found at other identical
1377 variable bindings *)
1379 (function non_pos
->
1382 (function (other_non_pos
,other_pos
) ->
1383 (* do we want equal? or just somehow compatible? eg non_pos
1384 binds only E, but other_non_pos binds both E and E1 *)
1385 non_pos
=*= other_non_pos
)
1386 splitted_relevant in
1390 (combine_pos negated_pos_vars
1391 (List.map
(function (_,x
) -> x
) others)))))
1394 (List.map
(function (non_pos
,_) -> List.assoc non_pos
extended_relevant)
1397 (* If the negated posvar is not bound at all, this function will
1398 nevertheless bind it to []. If we get rid of these bindings, then the
1399 matching of the term the position variable with the constraints will fail
1400 because some variables are unbound. So we let the binding be [] and then
1401 we will have to clean these up afterwards. This should be the only way
1402 that a position variable can have an empty binding. *)
1403 and combine_pos negated_pos_vars
others =
1409 (function positions ->
1410 function other_list
->
1412 match List.assoc posvar other_list
with
1413 Ast_c.MetaPosValList l1
->
1414 Common.union_set l1
positions
1415 | _ -> failwith
"bad value for a position variable"
1416 with Not_found
-> positions)
1418 (posvar
,Ast_c.MetaPosValList
positions))
1421 and process_a_generated_a_env_a_toplevel2
r env = function
1426 (rule
,_) when rule
=$
= r.rulename
-> false
1427 | (_,"ARGS") -> false
1430 let env_domain = List.map
(function (nm
,vl
) -> nm
) env in
1434 let (rl
,_) = Ast_cocci.get_meta_name md
in rl
=$
= r.rulename
)
1436 if Common.include_set
free_vars env_domain
1437 then Unparse_hrule.pp_rule
metavars r.ast_rule
env cfile
.full_fname
1438 | _ -> failwith
"multiple files not supported"
1440 and process_a_generated_a_env_a_toplevel rule
env ccs =
1441 Common.profile_code
"process_a_ctl_a_env_a_toplevel"
1442 (fun () -> process_a_generated_a_env_a_toplevel2 rule
env ccs)
1444 (* does side effects on C ast and on Cocci info rule *)
1445 and process_a_ctl_a_env_a_toplevel2
r e c
f =
1446 indent_do
(fun () ->
1447 show_or_not_celem "trying" c
.ast_c
;
1448 Flag.currentfile
:= Some
(f ^
":" ^
get_celem c
.ast_c
);
1449 let (trans_info, returned_any_states
, inherited_bindings
, newbindings
) =
1450 Common.save_excursion
Flag_ctl.loop_in_src_code
(fun () ->
1451 Flag_ctl.loop_in_src_code
:= !Flag_ctl.loop_in_src_code
||c
.contain_loop;
1453 (***************************************)
1454 (* !Main point! The call to the engine *)
1455 (***************************************)
1456 let model_ctl = CCI.model_for_ctl
r.dropped_isos
(Common.some c
.flow) e
1457 in CCI.mysat
model_ctl r.ctl
(r.used_after
, e
)
1460 if not returned_any_states
1463 show_or_not_celem "found match in" c
.ast_c
;
1464 show_or_not_trans_info trans_info;
1465 List.iter
(show_or_not_binding "out") newbindings
;
1467 r.was_matched
:= true;
1469 if not
(null
trans_info)
1471 c
.was_modified
:= true;
1473 (* les "more than one var in a decl" et "already tagged token"
1474 * font crasher coccinelle. Si on a 5 fichiers, donc on a 5
1475 * failed. Le try limite le scope des crashes pendant la
1476 * trasformation au fichier concerne. *)
1478 (* modify ast via side effect *)
1479 ignore
(Transformation_c.transform
r.rulename
r.dropped_isos
1480 inherited_bindings
trans_info (Common.some c
.flow));
1481 with Timeout
-> raise Timeout
| UnixExit i
-> raise
(UnixExit i
)
1484 Some
(List.map
(function x
-> x
@inherited_bindings
) newbindings
)
1488 and process_a_ctl_a_env_a_toplevel a b c
f=
1489 Common.profile_code
"process_a_ctl_a_env_a_toplevel"
1490 (fun () -> process_a_ctl_a_env_a_toplevel2 a b c
f)
1493 let rec bigloop2 rs
(ccs: file_info list
) =
1494 let init_es = [(Ast_c.emptyMetavarsBinding
,[])] in
1495 let es = ref init_es in
1496 let ccs = ref ccs in
1497 let rules_that_have_ever_matched = ref [] in
1499 (* looping over the rules *)
1500 rs
+> List.iter
(fun r ->
1502 InitialScriptRuleCocciInfo
r | FinalScriptRuleCocciInfo
r -> ()
1503 | ScriptRuleCocciInfo
r ->
1504 if !Flag_cocci.show_ctl_text
then begin
1505 Common.pr_xxxxxxxxxxxxxxxxx
();
1506 pr
("script: " ^
r.language
);
1507 Common.pr_xxxxxxxxxxxxxxxxx
();
1509 adjust_pp_with_indent
(fun () ->
1510 Format.force_newline
();
1511 let (l,mv,code
) = r.scr_ast_rule
in
1512 let deps = r.scr_dependencies
in
1513 Pretty_print_cocci.unparse
1514 (Ast_cocci.ScriptRule
(l,deps,mv,code
)));
1517 if !Flag.show_misc
then print_endline
"RESULT =";
1521 (function (cache
, newes
) ->
1522 function (e
, rules_that_have_matched
) ->
1523 match r.language
with
1525 apply_python_rule r cache newes e rules_that_have_matched
1526 rules_that_have_ever_matched
1528 concat_headers_and_c !ccs +> List.iter
(fun (c
,_) ->
1531 Printf.printf
"Flow: %s\r\nFlow!\r\n%!" c
.fullstring
);
1534 Printf.printf
"Unknown language: %s\n" r.language
;
1539 es := (if newes
= [] then init_es else newes
);
1540 | CocciRuleCocciInfo
r ->
1541 apply_cocci_rule r rules_that_have_ever_matched
1544 if !Flag.sgrep_mode2
1546 (* sgrep can lead to code that is not parsable, but we must
1547 * still call rebuild_info_c_and_headers to pretty print the
1548 * action (MINUS), so that later the diff will show what was
1549 * matched by sgrep. But we don't want the parsing error message
1550 * hence the following flag setting. So this code propably
1551 * will generate a NotParsedCorrectly for the matched parts
1552 * and the very final pretty print and diff will work
1554 Flag_parsing_c.verbose_parsing
:= false;
1555 ccs := rebuild_info_c_and_headers !ccs false
1557 !ccs (* return final C asts *)
1560 Common.profile_code
"bigloop" (fun () -> bigloop2 a b
)
1562 let initial_final_bigloop2 ty rebuild
r =
1563 if !Flag_cocci.show_ctl_text
then
1565 Common.pr_xxxxxxxxxxxxxxxxx
();
1566 pr
(ty ^
": " ^
r.language
);
1567 Common.pr_xxxxxxxxxxxxxxxxx
();
1569 adjust_pp_with_indent
(fun () ->
1570 Format.force_newline
();
1571 Pretty_print_cocci.unparse
(rebuild
r.scr_ast_rule
r.scr_dependencies
));
1574 match r.language
with
1576 (* include_match makes no sense in an initial or final rule, although
1577 we have no way to prevent it *)
1578 let _ = apply_python_rule r [] [] [] [] (ref []) in
1581 Printf.printf
"Unknown language for initial/final script: %s\n"
1584 let initial_final_bigloop a b c
=
1585 Common.profile_code
"initial_final_bigloop"
1586 (fun () -> initial_final_bigloop2 a b c
)
1588 (*****************************************************************************)
1589 (* The main functions *)
1590 (*****************************************************************************)
1592 let pre_engine2 (coccifile
, isofile
) =
1593 show_or_not_cocci coccifile isofile
;
1594 Pycocci.set_coccifile coccifile
;
1597 if not
(Common.lfile_exists
isofile)
1599 pr2
("warning: Can't find default iso file: " ^
isofile);
1602 else Some
isofile in
1604 (* useful opti when use -dir *)
1605 let (metavars,astcocci
,free_var_lists
,negated_pos_lists
,used_after_lists
,
1606 positions_lists
,toks
,_) =
1607 sp_of_file coccifile
isofile in
1608 let ctls = ctls_of_ast astcocci used_after_lists positions_lists
in
1610 g_contain_typedmetavar := sp_contain_typed_metavar astcocci
;
1612 check_macro_in_sp_and_adjust toks
;
1614 show_or_not_ctl_tex astcocci
ctls;
1617 prepare_cocci ctls free_var_lists negated_pos_lists
1618 used_after_lists positions_lists
metavars astcocci
in
1620 let used_languages =
1622 (function languages
->
1624 ScriptRuleCocciInfo
(r) ->
1625 if List.mem
r.language languages
then
1628 r.language
::languages
1632 let initialized_languages =
1634 (function languages
->
1636 InitialScriptRuleCocciInfo
(r) ->
1637 (if List.mem
r.language languages
1640 ("double initializer found for "^
r.language
));
1641 if interpret_dependencies [] [] r.scr_dependencies
1644 initial_final_bigloop "initial"
1645 (fun (x
,_,y
) -> fun deps ->
1646 Ast_cocci.InitialScriptRule
(x
,deps,y
))
1648 r.language
::languages
1654 let uninitialized_languages =
1656 (fun used
-> not
(List.mem used
initialized_languages))
1659 List.iter
(fun lgg
->
1660 initial_final_bigloop "initial"
1661 (fun (x
,_,y
) -> fun deps ->
1662 Ast_cocci.InitialScriptRule
(x
,deps,y
))
1663 (make_init (-1) lgg
Ast_cocci.NoDep
"");
1665 uninitialized_languages;
1670 Common.profile_code
"pre_engine" (fun () -> pre_engine2 a
)
1672 let full_engine2 (cocci_infos,toks
) cfiles
=
1674 show_or_not_cfiles cfiles
;
1676 (* optimisation allowing to launch coccinelle on all the drivers *)
1677 if !Flag_cocci.worth_trying_opt
&& not
(worth_trying cfiles toks
)
1683 pr2
("No matches found for " ^
(Common.join
" " toks
)
1684 ^
"\nSkipping:" ^
(Common.join
" " cfiles
)));
1685 cfiles
+> List.map
(fun s -> s, None
)
1690 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1691 if !Flag.show_misc
then pr
"let's go";
1692 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1694 let choose_includes =
1695 match !Flag_cocci.include_options
with
1696 Flag_cocci.I_UNSPECIFIED
->
1697 if !g_contain_typedmetavar
1698 then Flag_cocci.I_NORMAL_INCLUDES
1699 else Flag_cocci.I_NO_INCLUDES
1701 let c_infos = prepare_c cfiles
choose_includes in
1703 (* ! the big loop ! *)
1704 let c_infos'
= bigloop cocci_infos c_infos in
1706 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1707 if !Flag.show_misc
then pr
"Finished";
1708 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1709 if !Flag_ctl.graphical_trace
then gen_pdf_graph ();
1711 c_infos'
+> List.map
(fun c_or_h
->
1712 if !(c_or_h
.was_modified_once
)
1716 Common.new_temp_file
"cocci-output" ("-" ^ c_or_h
.fname
) in
1718 if c_or_h
.fkind
=*= Header
1719 then pr2
("a header file was modified: " ^ c_or_h
.fname
);
1721 (* and now unparse everything *)
1722 cfile_of_program (for_unparser c_or_h
.asts
) outfile;
1724 show_or_not_diff c_or_h
.fpath
outfile;
1727 if !Flag.sgrep_mode2
then None
else Some
outfile)
1729 else (c_or_h
.fpath
, None
))
1732 let full_engine a b
=
1733 Common.profile_code
"full_engine"
1734 (fun () -> let res = full_engine2 a b
in (*Gc.print_stat stderr; *)res)
1736 let post_engine2 (cocci_infos,_) =
1739 (function languages
->
1741 FinalScriptRuleCocciInfo
(r) ->
1742 (if List.mem
r.language languages
1743 then failwith
("double finalizer found for "^
r.language
));
1744 initial_final_bigloop "final"
1745 (fun (x
,_,y
) -> fun deps -> Ast_cocci.FinalScriptRule
(x
,deps,y
))
1747 r.language
::languages
1753 Common.profile_code
"post_engine" (fun () -> post_engine2 a
)
1755 (*****************************************************************************)
1756 (* check duplicate from result of full_engine *)
1757 (*****************************************************************************)
1759 let check_duplicate_modif2 xs =
1760 (* opti: let groups = Common.groupBy (fun (a,resa) (b,resb) -> a =$= b) xs *)
1761 if !Flag_cocci.verbose_cocci
1762 then pr2
("Check duplication for " ^ i_to_s
(List.length
xs) ^
" files");
1764 let groups = Common.group_assoc_bykey_eff
xs in
1765 groups +> Common.map_filter
(fun (file, xs) ->
1767 | [] -> raise Impossible
1768 | [res] -> Some
(file, res)
1772 if not
(List.for_all
(fun res2
-> res2
=*= None
) xs)
1774 pr2
("different modification result for " ^
file);
1777 else Some
(file, None
)
1779 if not
(List.for_all
(fun res2
->
1783 let diff = Common.cmd_to_list
("diff -u -b -B "^
res^
" "^res2
)
1787 pr2
("different modification result for " ^
file);
1790 else Some
(file, Some
res)
1792 let check_duplicate_modif a
=
1793 Common.profile_code
"check_duplicate" (fun () -> check_duplicate_modif2 a
)