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 let (_
,xs
,_
,_
,_
,_
,_
,_
) as res
= Parse_cocci.process file iso
false in
73 (match Prepare_ocamlcocci.prepare file xs
with
75 | Some ocaml_script_file
->
77 Prepare_ocamlcocci.load_file ocaml_script_file
;
78 Prepare_ocamlcocci.clean_file ocaml_script_file
);
80 let sp_of_file file iso
=
81 Common.profile_code
"parse cocci" (fun () -> sp_of_file2 file iso
)
84 (* --------------------------------------------------------------------- *)
86 (* --------------------------------------------------------------------- *)
88 Ograph_extended.print_ograph_mutable flow
"/tmp/test.dot" true
91 let ast_to_flow_with_error_messages2 x
=
93 try Ast_to_flow.ast_to_control_flow x
94 with Ast_to_flow.Error x
->
95 Ast_to_flow.report_error x
;
98 flowopt +> do_option
(fun flow
->
99 (* This time even if there is a deadcode, we still have a
100 * flow graph, so I can try the transformation and hope the
101 * deadcode will not bother us.
103 try Ast_to_flow.deadcode_detection flow
104 with Ast_to_flow.Error
(Ast_to_flow.DeadCode x
) ->
105 Ast_to_flow.report_error
(Ast_to_flow.DeadCode x
);
108 let ast_to_flow_with_error_messages a
=
109 Common.profile_code
"flow" (fun () -> ast_to_flow_with_error_messages2 a
)
112 (* --------------------------------------------------------------------- *)
114 (* --------------------------------------------------------------------- *)
116 let ctls_of_ast2 ast
(ua
,fua
,fuas
) pos
=
118 (function ast
-> function (ua
,(fua
,(fuas
,pos
))) ->
122 else Asttoctl2.asttoctl ast
(ua
,fua
,fuas
) pos
)
123 (Asttomember.asttomember ast ua
))
124 ast
(List.combine ua
(List.combine fua
(List.combine fuas pos
)))
126 let ctls_of_ast ast ua
=
127 Common.profile_code
"asttoctl2" (fun () -> ctls_of_ast2 ast ua
)
129 (*****************************************************************************)
130 (* Some debugging functions *)
131 (*****************************************************************************)
135 let show_or_not_cfile2 cfile
=
136 if !Flag_cocci.show_c
then begin
137 Common.pr2_xxxxxxxxxxxxxxxxx
();
138 pr2
("processing C file: " ^ cfile
);
139 Common.pr2_xxxxxxxxxxxxxxxxx
();
140 Common.command2
("cat " ^ cfile
);
142 let show_or_not_cfile a
=
143 Common.profile_code
"show_xxx" (fun () -> show_or_not_cfile2 a
)
145 let show_or_not_cfiles cfiles
= List.iter
show_or_not_cfile cfiles
148 let show_or_not_cocci2 coccifile isofile
=
149 if !Flag_cocci.show_cocci
then begin
150 Common.pr2_xxxxxxxxxxxxxxxxx
();
151 pr2
("processing semantic patch file: " ^ coccifile
);
152 isofile
+> (fun s
-> pr2
("with isos from: " ^ s
));
153 Common.pr2_xxxxxxxxxxxxxxxxx
();
154 Common.command2
("cat " ^ coccifile
);
157 let show_or_not_cocci a b
=
158 Common.profile_code
"show_xxx" (fun () -> show_or_not_cocci2 a b
)
160 (* ---------------------------------------------------------------------- *)
163 let fix_sgrep_diffs l
=
165 List.filter
(function s
-> (s
=~
"^\\+\\+\\+") || not
(s
=~
"^\\+")) l in
166 let l = List.rev
l in
167 (* adjust second number for + code *)
168 let rec loop1 n
= function
171 if s
=~
"^-" && not
(s
=~
"^---")
172 then s
:: loop1 (n
+1) ss
175 (match Str.split
(Str.regexp
" ") s
with
178 match Str.split
(Str.regexp
",") pl
with
181 | _
-> failwith
"bad + line information" in
182 let n2 = int_of_string
n2 in
183 (Printf.sprintf
"%s %s %s,%d %s" bef min n1
(n2-n
)
184 (String.concat
" " aft
))
186 | _
-> failwith
"bad @@ information")
187 else s
:: loop1 n ss
in
188 let rec loop2 n
= function
195 (match Str.split
(Str.regexp
" ") s
with
198 match (Str.split
(Str.regexp
",") min
,
199 Str.split
(Str.regexp
",") pl
) with
200 ([_
;m2
],[n1
;n2]) -> (m2
,n1
,n2)
201 | ([_
],[n1
;n2]) -> ("1",n1
,n2)
202 | ([_
;m2
],[n1
]) -> (m2
,n1
,"1")
203 | ([_
],[n1
]) -> ("1",n1
,"1")
204 | _
-> failwith
"bad -/+ line information" in
206 int_of_string
(String.sub
n1 1 ((String.length
n1)-1)) in
207 let m2 = int_of_string
m2 in
208 let n2 = int_of_string
n2 in
209 (Printf.sprintf
"%s %s +%d,%d %s" bef min
(n1-n
) n2
210 (String.concat
" " aft
))
211 :: loop2 (n
+(m2-n2)) ss
212 | _
-> failwith
"bad @@ information")
213 else s
:: loop2 n ss
in
214 loop2 0 (List.rev
(loop1 0 l))
216 let normalize_path file
=
218 if String.get file
0 = '
/'
then file
else (Sys.getcwd
()) ^
"/" ^ file
in
219 let elements = Str.split_delim
(Str.regexp
"/") fullpath in
220 let rec loop prev
= function
221 [] -> String.concat
"/" (List.rev prev
)
222 | "." :: rest
-> loop prev rest
225 x
::xs
-> loop xs rest
226 | _
-> failwith
"bad path")
227 | x
::rest
-> loop (x
::prev
) rest
in
230 let show_or_not_diff2 cfile outfile
=
231 if !Flag_cocci.show_diff
then begin
232 match Common.fst
(Compare_c.compare_to_original cfile outfile
) with
233 Compare_c.Correct
-> () (* diff only in spacing, etc *)
235 (* may need --strip-trailing-cr under windows *)
239 match !Flag_parsing_c.diff_lines
with
240 | None
-> "diff -u -p " ^ cfile ^
" " ^ outfile
241 | Some n
-> "diff -U "^n^
" -p "^cfile^
" "^outfile
in
243 let res = Common.cmd_to_list
line in
244 match (!Flag.patch
,res) with
245 (* create something that looks like the output of patch *)
246 (Some prefix
,minus_file
::plus_file
::rest
) ->
248 let lp = String.length
prefix in
249 if String.get
prefix (lp-1) = '
/'
250 then String.sub
prefix 0 (lp-1)
252 let drop_prefix file
=
253 let file = normalize_path file in
254 if Str.string_match
(Str.regexp
prefix) file 0
256 let lp = String.length
prefix in
257 let lf = String.length
file in
259 then String.sub
file lp (lf - lp)
262 (Printf.sprintf
"prefix %s doesn't match file %s"
266 (Printf.sprintf
"prefix %s doesn't match file %s"
269 match List.rev
(Str.split
(Str.regexp
" ") line) with
270 new_file
::old_file
::cmdrev
->
274 (List.rev
("/tmp/nothing" :: old_file
:: cmdrev
))
276 let old_base_file = drop_prefix old_file
in
279 (("b"^
old_base_file)::("a"^
old_base_file)::cmdrev
))
280 | _
-> failwith
"bad command" in
281 let (minus_line
,plus_line
) =
283 then (minus_file
,"+++ /tmp/nothing")
285 match (Str.split
(Str.regexp
"[ \t]") minus_file
,
286 Str.split
(Str.regexp
"[ \t]") plus_file
) with
287 ("---"::old_file
::old_rest
,"+++"::new_file
::new_rest
) ->
288 let old_base_file = drop_prefix old_file
in
290 ("---"::("a"^
old_base_file)::old_rest
),
292 ("+++"::("b"^
old_base_file)::new_rest
))
295 (Printf.sprintf
"bad diff header lines: %s %s"
296 (String.concat
":" l1
) (String.concat
":" l2
)) in
297 diff_line::minus_line
::plus_line
::rest
299 let xs = if !Flag.sgrep_mode2
then fix_sgrep_diffs xs else xs in
302 let show_or_not_diff a b
=
303 Common.profile_code
"show_xxx" (fun () -> show_or_not_diff2 a b
)
306 (* the derived input *)
308 let show_or_not_ctl_tex2 astcocci ctls
=
309 if !Flag_cocci.show_ctl_tex
then begin
310 Ctltotex.totex
("/tmp/__cocci_ctl.tex") astcocci ctls
;
311 Common.command2
("cd /tmp; latex __cocci_ctl.tex; " ^
312 "dvips __cocci_ctl.dvi -o __cocci_ctl.ps;" ^
313 "gv __cocci_ctl.ps &");
315 let show_or_not_ctl_tex a b
=
316 Common.profile_code
"show_xxx" (fun () -> show_or_not_ctl_tex2 a b
)
319 let show_or_not_rule_name ast rulenb
=
320 if !Flag_cocci.show_ctl_text
or !Flag.show_trying
or
321 !Flag.show_transinfo
or !Flag_cocci.show_binding_in_out
326 Ast_cocci.CocciRule
(nm
, (deps
, drops
, exists
), x
, _
, _
) -> nm
327 | _
-> i_to_s rulenb
in
328 Common.pr_xxxxxxxxxxxxxxxxx
();
330 Common.pr_xxxxxxxxxxxxxxxxx
()
333 let show_or_not_scr_rule_name rulenb
=
334 if !Flag_cocci.show_ctl_text
or !Flag.show_trying
or
335 !Flag.show_transinfo
or !Flag_cocci.show_binding_in_out
338 let name = i_to_s rulenb
in
339 Common.pr_xxxxxxxxxxxxxxxxx
();
340 pr
("script rule " ^
name ^
" = ");
341 Common.pr_xxxxxxxxxxxxxxxxx
()
344 let show_or_not_ctl_text2 ctl ast rulenb
=
345 if !Flag_cocci.show_ctl_text
then begin
347 adjust_pp_with_indent
(fun () ->
348 Format.force_newline
();
349 Pretty_print_cocci.print_plus_flag
:= true;
350 Pretty_print_cocci.print_minus_flag
:= true;
351 Pretty_print_cocci.unparse ast
;
356 adjust_pp_with_indent
(fun () ->
357 Format.force_newline
();
358 Pretty_print_engine.pp_ctlcocci
359 !Flag_cocci.show_mcodekind_in_ctl
!Flag_cocci.inline_let_ctl ctl
;
363 let show_or_not_ctl_text a b c
=
364 Common.profile_code
"show_xxx" (fun () -> show_or_not_ctl_text2 a b c
)
368 (* running information *)
369 let get_celem celem
: string =
371 Ast_c.Definition
({Ast_c.f_name
= namefuncs
;},_
) ->
372 Ast_c.str_of_name namefuncs
374 (Ast_c.DeclList
([{Ast_c.v_namei
= Some
(name, _
);}, _
], _
)) ->
375 Ast_c.str_of_name
name
378 let show_or_not_celem2 prelude celem
=
381 | Ast_c.Definition
({Ast_c.f_name
= namefuncs
},_
) ->
382 let funcs = Ast_c.str_of_name namefuncs
in
383 Flag.current_element
:= funcs;
384 (" function: ",funcs)
386 (Ast_c.DeclList
([{Ast_c.v_namei
= Some
(name,_
)}, _
], _
)) ->
387 let s = Ast_c.str_of_name
name in
388 Flag.current_element
:= s;
391 Flag.current_element
:= "something_else";
392 (" ","something else");
394 if !Flag.show_trying
then pr2
(prelude ^ tag ^ trying
)
396 let show_or_not_celem a b
=
397 Common.profile_code
"show_xxx" (fun () -> show_or_not_celem2 a b
)
400 let show_or_not_trans_info2 trans_info
=
401 (* drop witness tree indices for printing *)
403 List.map
(function (index
,trans_info) -> trans_info) trans_info in
404 if !Flag.show_transinfo
then begin
405 if null
trans_info then pr2
"transformation info is empty"
407 pr2
"transformation info returned:";
409 List.sort
(function (i1
,_
,_
) -> function (i2
,_
,_
) -> compare i1 i2
)
413 trans_info +> List.iter
(fun (i
, subst
, re
) ->
414 pr2
("transform state: " ^
(Common.i_to_s i
));
416 adjust_pp_with_indent_and_header
"with rule_elem: " (fun () ->
417 Pretty_print_cocci.print_plus_flag
:= true;
418 Pretty_print_cocci.print_minus_flag
:= true;
419 Pretty_print_cocci.rule_elem
"" re
;
421 adjust_pp_with_indent_and_header
"with binding: " (fun () ->
422 Pretty_print_engine.pp_binding subst
;
429 let show_or_not_trans_info a
=
430 Common.profile_code
"show_xxx" (fun () -> show_or_not_trans_info2 a
)
434 let show_or_not_binding2 s binding
=
435 if !Flag_cocci.show_binding_in_out
then begin
436 adjust_pp_with_indent_and_header
("binding " ^
s ^
" = ") (fun () ->
437 Pretty_print_engine.pp_binding binding
440 let show_or_not_binding a b
=
441 Common.profile_code
"show_xxx" (fun () -> show_or_not_binding2 a b
)
445 (*****************************************************************************)
446 (* Some helper functions *)
447 (*****************************************************************************)
449 let worth_trying cfiles tokens
=
450 (* drop the following line for a list of list by rules. since we don't
451 allow multiple minirules, all the tokens within a rule should be in
452 a single CFG entity *)
453 match (!Flag_cocci.windows
,tokens
) with
454 (true,_
) | (_
,None
) -> true
456 (* could also modify the code in get_constants.ml *)
457 let tokens = tokens +> List.map
(fun s ->
459 | _
when s =~
"^[A-Za-z_][A-Za-z_0-9]*$" ->
462 | _
when s =~
"^[A-Za-z_]" ->
465 | _
when s =~
".*[A-Za-z_]$" ->
470 let com = sprintf
"egrep -q '(%s)' %s" (join
"|" tokens) (join
" " cfiles
)
472 (match Sys.command
com with
473 | 0 (* success *) -> true
476 then Printf.printf
"grep failed: %s\n" com);
477 false (* no match, so not worth trying *))
479 let check_macro_in_sp_and_adjust = function
482 tokens +> List.iter
(fun s ->
483 if Hashtbl.mem
!Parse_c._defs
s
485 if !Flag_cocci.verbose_cocci
then begin
486 pr2
"warning: macro in semantic patch was in macro definitions";
487 pr2
("disabling macro expansion for " ^
s);
489 Hashtbl.remove
!Parse_c._defs
s
493 let contain_loop gopt
=
496 g#nodes#tolist
+> List.exists
(fun (xi
, node
) ->
497 Control_flow_c.extract_is_loop node
499 | None
-> true (* means nothing, if no g then will not model check *)
503 let sp_contain_typed_metavar_z toplevel_list_list
=
504 let bind x y
= x
or y
in
505 let option_default = false in
506 let mcode _ _
= option_default in
507 let donothing r k e
= k e
in
509 let expression r k e
=
510 match Ast_cocci.unwrap e
with
511 | Ast_cocci.MetaExpr
(_
,_
,_
,Some t
,_
,_
) -> true
512 | Ast_cocci.MetaExpr
(_
,_
,_
,_
,Ast_cocci.LocalID
,_
) -> true
517 Visitor_ast.combiner bind option_default
518 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
519 donothing donothing donothing donothing
520 donothing expression donothing donothing donothing donothing donothing
521 donothing donothing donothing donothing donothing
523 toplevel_list_list
+>
525 (function (nm
,_
,rule
) ->
526 (List.exists
combiner.Visitor_ast.combiner_top_level rule
))
528 let sp_contain_typed_metavar rules
=
529 sp_contain_typed_metavar_z
533 Ast_cocci.CocciRule
(a
,b
,c
,d
,_
) -> (a
,b
,c
)
534 | _
-> failwith
"error in filter")
538 Ast_cocci.CocciRule
(a
,b
,c
,d
,Ast_cocci.Normal
) -> true
544 (* finding among the #include the one that we need to parse
545 * because they may contain useful type definition or because
546 * we may have to modify them
548 * For the moment we base in part our heuristic on the name of the file, e.g.
549 * serio.c is related we think to #include <linux/serio.h>
551 let rec search_include_path searchlist relpath
=
552 match searchlist
with
555 let file = Filename.concat hd relpath
in
556 if Sys.file_exists
file then
559 search_include_path tail relpath
561 let interpret_include_path relpath
=
563 match !Flag_cocci.include_path
with
567 search_include_path searchlist relpath
569 let (includes_to_parse
:
570 (Common.filename
* Parse_c.program2
) list
->
571 Flag_cocci.include_options
-> 'a
) = fun xs choose_includes
->
572 match choose_includes
with
573 Flag_cocci.I_UNSPECIFIED
-> failwith
"not possible"
574 | Flag_cocci.I_NO_INCLUDES
-> []
576 let all_includes = x
=*= Flag_cocci.I_ALL_INCLUDES
in
577 xs +> List.map
(fun (file, cs
) ->
578 let dir = Common.dirname
file in
580 cs
+> Common.map_filter
(fun (c
,_info_item
) ->
584 {Ast_c.i_include
= ((x
,ii
)); i_rel_pos
= info_h_pos
;}) ->
587 let relpath = Common.join
"/" xs in
588 let f = Filename.concat
dir (relpath) in
589 if (Sys.file_exists
f) then
592 if !Flag_cocci.relax_include_path
593 (* for our tests, all the files are flat in the current dir *)
595 let attempt2 = Filename.concat
dir (Common.last
xs) in
596 if not
(Sys.file_exists
attempt2) && all_includes
598 interpret_include_path relpath
601 if all_includes then interpret_include_path relpath
604 | Ast_c.NonLocal
xs ->
605 let relpath = Common.join
"/" xs in
607 Common.fileprefix
(Common.last
xs) =$
= Common.fileprefix
file
609 interpret_include_path relpath
611 | Ast_c.Weird _
-> None
617 let rec interpret_dependencies local global
= function
618 Ast_cocci.Dep
s -> List.mem
s local
619 | Ast_cocci.AntiDep
s ->
620 (if !Flag_ctl.steps
!= None
621 then failwith
"steps and ! dependency incompatible");
622 not
(List.mem
s local
)
623 | Ast_cocci.EverDep
s -> List.mem
s global
624 | Ast_cocci.NeverDep
s ->
625 (if !Flag_ctl.steps
!= None
626 then failwith
"steps and ! dependency incompatible");
627 not
(List.mem
s global
)
628 | Ast_cocci.AndDep
(s1
,s2
) ->
629 (interpret_dependencies local global s1
) &&
630 (interpret_dependencies local global s2
)
631 | Ast_cocci.OrDep
(s1
,s2
) ->
632 (interpret_dependencies local global s1
) or
633 (interpret_dependencies local global s2
)
634 | Ast_cocci.NoDep
-> true
635 | Ast_cocci.FailDep
-> false
637 let rec print_dependencies str local global dep
=
638 if !Flag_cocci.show_dependencies
643 let rec loop = function
644 Ast_cocci.Dep
s | Ast_cocci.AntiDep
s ->
645 if not
(List.mem
s !seen)
649 then pr2
(s^
" satisfied")
650 else pr2
(s^
" not satisfied");
653 | Ast_cocci.EverDep
s | Ast_cocci.NeverDep
s ->
654 if not
(List.mem
s !seen)
658 then pr2
(s^
" satisfied")
659 else pr2
(s^
" not satisfied");
662 | Ast_cocci.AndDep
(s1
,s2
) ->
665 | Ast_cocci.OrDep
(s1
,s2
) ->
668 | Ast_cocci.NoDep
-> ()
669 | Ast_cocci.FailDep
-> pr2
"False not satisfied" in
673 (* --------------------------------------------------------------------- *)
674 (* #include relative position in the file *)
675 (* --------------------------------------------------------------------- *)
677 (* compute the set of new prefixes
679 * "a/b/x"; (* in fact it is now a list of string so ["a";"b";"x"] *)
683 * it would give
for the first element
684 * ""; "a"; "a/b"; "a/b/x"
688 * update
: if the
include is inside a ifdef a put nothing
. cf
-test incl
.
689 * this is because we dont want code added inside ifdef
.
692 let compute_new_prefixes xs =
693 xs +> Common.map_withenv
(fun already
xs ->
694 let subdirs_prefixes = Common.inits
xs in
695 let new_first = subdirs_prefixes +> List.filter
(fun x
->
696 not
(List.mem x already
)
705 (* does via side effect on the ref in the Include in Ast_c *)
706 let rec update_include_rel_pos cs
=
707 let only_include = cs
+> Common.map_filter
(fun c
->
709 | Ast_c.CppTop
(Ast_c.Include
{Ast_c.i_include
= ((x
,_
));
711 i_is_in_ifdef
= inifdef
}) ->
713 | Ast_c.Weird _
-> None
722 let (locals
, nonlocals
) =
723 only_include +> Common.partition_either
(fun (c
, aref
) ->
725 | Ast_c.Local x
-> Left
(x
, aref
)
726 | Ast_c.NonLocal x
-> Right
(x
, aref
)
727 | Ast_c.Weird x
-> raise Impossible
730 update_rel_pos_bis locals
;
731 update_rel_pos_bis nonlocals
;
733 and update_rel_pos_bis
xs =
734 let xs'
= List.map fst
xs in
735 let the_first = compute_new_prefixes xs'
in
736 let the_last = List.rev
(compute_new_prefixes (List.rev
xs'
)) in
737 let merged = Common.zip
xs (Common.zip
the_first the_last) in
738 merged +> List.iter
(fun ((x
, aref
), (the_first, the_last)) ->
741 Ast_c.first_of
= the_first;
742 Ast_c.last_of
= the_last;
747 (*****************************************************************************)
748 (* All the information needed around the C elements and Cocci rules *)
749 (*****************************************************************************)
751 type toplevel_c_info
= {
752 ast_c
: Ast_c.toplevel
; (* contain refs so can be modified *)
753 tokens_c
: Parser_c.token list
;
756 flow
: Control_flow_c.cflow
option; (* it's the "fixed" flow *)
759 env_typing_before
: TAC.environment
;
760 env_typing_after
: TAC.environment
;
762 was_modified
: bool ref;
767 type toplevel_cocci_info_script_rule
= {
768 scr_rulename
: string;
771 (Ast_cocci.script_meta_name
* Ast_cocci.meta_name
*
772 Ast_cocci.metavar
) list
*
775 scr_dependencies
: Ast_cocci.dependency
;
780 type toplevel_cocci_info_cocci_rule
= {
781 ctl
: Lib_engine.ctlcocci
* (CCI.pred list list
);
782 metavars
: Ast_cocci.metavar list
;
783 ast_rule
: Ast_cocci.rule
;
784 isexp
: bool; (* true if + code is an exp, only for Flag.make_hrule *)
787 dependencies
: Ast_cocci.dependency
;
788 (* There are also some hardcoded rule names in parse_cocci.ml:
789 * let reserved_names = ["all";"optional_storage";"optional_qualifier"]
791 dropped_isos
: string list
;
792 free_vars
: Ast_cocci.meta_name list
;
793 negated_pos_vars
: Ast_cocci.meta_name list
;
794 used_after
: Ast_cocci.meta_name list
;
795 positions
: Ast_cocci.meta_name list
;
798 ruletype
: Ast_cocci.ruletype
;
800 was_matched
: bool ref;
803 type toplevel_cocci_info
=
804 ScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
805 | InitialScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
806 | FinalScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
807 | CocciRuleCocciInfo
of toplevel_cocci_info_cocci_rule
809 type cocci_info
= toplevel_cocci_info list
* string list
option (* tokens *)
811 type kind_file
= Header
| Source
815 was_modified_once
: bool ref;
816 asts
: toplevel_c_info list
;
821 let g_contain_typedmetavar = ref false
824 let last_env_toplevel_c_info xs =
825 (Common.last
xs).env_typing_after
827 let concat_headers_and_c (ccs
: file_info list
)
828 : (toplevel_c_info
* string) list
=
829 (List.concat
(ccs
+> List.map
(fun x
->
830 x
.asts
+> List.map
(fun x'
->
833 let for_unparser xs =
834 xs +> List.map
(fun x
->
835 (x
.ast_c
, (x
.fullstring
, x
.tokens_c
)), Unparse_c.PPviastr
838 let gen_pdf_graph () =
839 (Ctl_engine.get_graph_files
()) +> List.iter
(fun outfile
->
840 Printf.printf
"Generation of %s%!" outfile
;
841 let filename_stack = Ctl_engine.get_graph_comp_files outfile
in
842 List.iter
(fun filename
->
843 ignore
(Unix.system
("dot " ^ filename ^
" -Tpdf -o " ^ filename ^
".pdf;"))
845 let (head
,tail
) = (List.hd
filename_stack, List.tl
filename_stack) in
846 ignore
(Unix.system
("cp " ^ head ^
".pdf " ^ outfile ^
".pdf;"));
847 tail
+> List.iter
(fun filename
->
848 ignore
(Unix.system
("mv " ^ outfile ^
".pdf /tmp/tmp.pdf;"));
849 ignore
(Unix.system
("pdftk " ^ filename ^
".pdf /tmp/tmp.pdf cat output " ^ outfile ^
".pdf"));
851 ignore
(Unix.system
("rm /tmp/tmp.pdf;"));
852 List.iter
(fun filename
->
853 ignore
(Unix.system
("rm " ^ filename ^
" " ^ filename ^
".pdf;"))
855 Printf.printf
" - Done\n")
857 let local_python_code =
858 "from coccinelle import *\n"
861 "import coccinelle\n"^
863 "import coccilib.org\n"^
864 "import coccilib.report\n" ^
868 let make_init name rulenb lang deps code
=
872 scr_ast_rule
= (lang
, mv, code
);
874 scr_dependencies
= deps
;
876 script_code
= (if lang
= "python" then python_code else "") ^code
879 (* --------------------------------------------------------------------- *)
880 let prepare_cocci ctls free_var_lists negated_pos_lists
881 (ua
,fua
,fuas
) positions_list metavars astcocci
=
883 let gathered = Common.index_list_1
884 (zip
(zip
(zip
(zip
(zip
(zip
(zip
(zip ctls metavars
) astcocci
)
886 negated_pos_lists
) ua
) fua
) fuas
) positions_list
)
889 (fun (((((((((ctl_toplevel_list
,metavars
),ast
),free_var_list
),
890 negated_pos_list
),ua
),fua
),fuas
),positions_list
),rulenb
) ->
892 let is_script_rule r
=
894 Ast_cocci.ScriptRule _
895 | Ast_cocci.InitialScriptRule _
| Ast_cocci.FinalScriptRule _
-> true
898 if not
(List.length ctl_toplevel_list
=|= 1) && not
(is_script_rule ast
)
899 then failwith
"not handling multiple minirules";
902 Ast_cocci.ScriptRule
(name,lang
,deps
,mv,code
) ->
906 scr_ast_rule
= (lang
, mv, code
);
908 scr_dependencies
= deps
;
912 in ScriptRuleCocciInfo
r
913 | Ast_cocci.InitialScriptRule
(name,lang
,deps
,code
) ->
914 let r = make_init name rulenb lang deps code
in
915 InitialScriptRuleCocciInfo
r
916 | Ast_cocci.FinalScriptRule
(name,lang
,deps
,code
) ->
921 scr_ast_rule
= (lang
, mv, code
);
923 scr_dependencies
= deps
;
927 in FinalScriptRuleCocciInfo
r
928 | Ast_cocci.CocciRule
929 (rulename
,(dependencies
,dropped_isos
,z
),restast
,isexp
,ruletype
) ->
932 ctl
= List.hd ctl_toplevel_list
;
935 isexp
= List.hd isexp
;
937 dependencies
= dependencies
;
938 dropped_isos
= dropped_isos
;
939 free_vars
= List.hd free_var_list
;
940 negated_pos_vars
= List.hd negated_pos_list
;
941 used_after
= (List.hd ua
) @ (List.hd fua
);
942 positions
= List.hd positions_list
;
945 was_matched
= ref false;
950 (* --------------------------------------------------------------------- *)
952 let build_info_program cprogram env
=
954 let (cs
, parseinfos
) =
955 Common.unzip cprogram
in
958 parseinfos
+> List.map
(fun (s,toks
) -> toks
) +> List.flatten
in
960 (* I use cs' but really annotate_xxx work by doing side effects on cs *)
962 Comment_annotater_c.annotate_program
alltoks cs in
964 Type_annoter_c.annotate_program env
(*!g_contain_typedmetavar*) cs'
967 zip
cs_with_envs parseinfos
+> List.map
(fun ((c
, (enva
,envb
)), parseinfo
)->
968 let (fullstr
, tokens) = parseinfo
in
971 ast_to_flow_with_error_messages c
+>
972 Common.map_option
(fun flow ->
973 let flow = Ast_to_flow.annotate_loop_nodes
flow in
975 (* remove the fake nodes for julia *)
976 let fixed_flow = CCI.fix_flow_ctl
flow in
978 if !Flag_cocci.show_flow
then print_flow fixed_flow;
979 if !Flag_cocci.show_before_fixed_flow
then print_flow flow;
986 ast_c
= c
; (* contain refs so can be modified *)
988 fullstring
= fullstr
;
992 contain_loop = contain_loop flow;
994 env_typing_before
= enva
;
995 env_typing_after
= envb
;
997 was_modified
= ref false;
1003 (* Optimisation. Try not unparse/reparse the whole file when have modifs *)
1004 let rebuild_info_program cs file isexp
=
1005 cs +> List.map
(fun c
->
1006 if !(c
.was_modified
)
1008 let file = Common.new_temp_file
"cocci_small_output" ".c" in
1010 [(c
.ast_c
, (c
.fullstring
, c
.tokens_c
)), Unparse_c.PPnormal
]
1013 (* Common.command2 ("cat " ^ file); *)
1014 let cprogram = cprogram_of_file file in
1015 let xs = build_info_program cprogram c
.env_typing_before
in
1017 (* TODO: assert env has not changed,
1018 * if yes then must also reparse what follows even if not modified.
1019 * Do that only if contain_typedmetavar of course, so good opti.
1021 (* Common.list_init xs *) (* get rid of the FinalDef *)
1027 let rebuild_info_c_and_headers ccs isexp
=
1028 ccs
+> List.iter
(fun c_or_h
->
1029 if c_or_h
.asts
+> List.exists
(fun c
-> !(c
.was_modified
))
1030 then c_or_h
.was_modified_once
:= true;
1032 ccs
+> List.map
(fun c_or_h
->
1035 rebuild_info_program c_or_h
.asts c_or_h
.full_fname isexp
}
1040 let prepare_c files choose_includes
: file_info list
=
1041 let cprograms = List.map
cprogram_of_file_cached files
in
1042 let includes = includes_to_parse
(zip files
cprograms) choose_includes
in
1044 (* todo?: may not be good to first have all the headers and then all the c *)
1046 (includes +> List.map
(fun hpath
-> Right hpath
))
1048 ((zip files
cprograms) +>
1049 List.map
(fun (file, asts
) -> Left
(file, asts
)))
1052 let env = ref !TAC.initial_env
in
1054 let ccs = all +> Common.map_filter
(fun x
->
1057 if not
(Common.lfile_exists hpath
)
1059 pr2
("TYPE: header " ^ hpath ^
" not found");
1063 let h_cs = cprogram_of_file_cached hpath
in
1064 let info_h_cs = build_info_program h_cs !env in
1068 else last_env_toplevel_c_info info_h_cs
1071 fname
= Common.basename hpath
;
1074 was_modified_once
= ref false;
1078 | Left
(file, cprogram) ->
1079 (* todo?: don't update env ? *)
1080 let cs = build_info_program cprogram !env in
1081 (* we do that only for the c, not for the h *)
1082 ignore
(update_include_rel_pos (cs +> List.map
(fun x
-> x
.ast_c
)));
1084 fname
= Common.basename
file;
1087 was_modified_once
= ref false;
1096 (*****************************************************************************)
1097 (* Processing the ctls and toplevel C elements *)
1098 (*****************************************************************************)
1100 (* The main algorithm =~
1101 * The algorithm is roughly:
1102 * for_all ctl rules in SP
1103 * for_all minirule in rule (no more)
1104 * for_all binding (computed during previous phase)
1105 * for_all C elements
1106 * match control flow of function vs minirule
1107 * with the binding and update the set of possible
1108 * bindings, and returned the possibly modified function.
1109 * pretty print modified C elements and reparse it.
1112 * On ne prends que les newbinding ou returned_any_state est vrai.
1113 * Si ca ne donne rien, on prends ce qu'il y avait au depart.
1114 * Mais au nouveau depart de quoi ?
1115 * - si ca donne rien apres avoir traité toutes les fonctions avec ce binding ?
1116 * - ou alors si ca donne rien, apres avoir traité toutes les fonctions
1117 * avec tous les bindings du round d'avant ?
1119 * Julia pense qu'il faut prendre la premiere solution.
1120 * Example: on a deux environnements candidats, E1 et E2 apres avoir traité
1121 * la regle ctl 1. On arrive sur la regle ctl 2.
1122 * E1 ne donne rien pour la regle 2, on garde quand meme E1 pour la regle 3.
1123 * E2 donne un match a un endroit et rend E2' alors on utilise ca pour
1126 * I have not to look at used_after_list to decide to restart from
1127 * scratch. I just need to look if the binding list is empty.
1128 * Indeed, let's suppose that a SP have 3 regions/rules. If we
1129 * don't find a match for the first region, then if this first
1130 * region does not bind metavariable used after, that is if
1131 * used_after_list is empty, then mysat(), even if does not find a
1132 * match, will return a Left, with an empty transformation_info,
1133 * and so current_binding will grow. On the contrary if the first
1134 * region must bind some metavariables used after, and that we
1135 * dont find any such region, then mysat() will returns lots of
1136 * Right, and current_binding will not grow, and so we will have
1137 * an empty list of binding, and we will catch such a case.
1139 * opti: julia says that because the binding is
1140 * determined by the used_after_list, the items in the list
1141 * are kind of sorted, so could optimise the insert_set operations.
1145 (* r(ule), c(element in C code), e(nvironment) *)
1148 let rec loop k
= function
1152 then Some
(x
, function n
-> k
(n
:: xs))
1153 else loop (function vs
-> k
(x
:: vs
)) xs in
1154 loop (function x
-> x
) l
1156 let merge_env new_e old_e
=
1159 (function (ext
,old_e
) ->
1160 function (e
,rules
) as elem
->
1161 match findk (function (e1
,_
) -> e
=*= e1
) old_e
with
1162 None
-> (elem
:: ext
,old_e
)
1163 | Some
((_
,old_rules
),k
) ->
1164 (ext
,k
(e
,Common.union_set rules old_rules
)))
1166 old_e
@ (List.rev ext
)
1168 let contains_binding e
(_
,(r,m
),_
) =
1170 let _ = List.find
(function ((re
, rm
), _) -> r =*= re
&& m
=$
= rm
) e
in
1172 with Not_found
-> false
1174 let python_application mv ve
r =
1178 ((Some x
,None
),y
,z
) -> (x
,y
,z
)
1181 (Printf.sprintf
"unexpected ast metavar in rule %s"
1185 Pycocci.build_classes
(List.map
(function (x
,y
) -> x
) ve
);
1186 Pycocci.construct_variables
mv ve
;
1187 let _ = Pycocci.pyrun_simplestring
(local_python_code ^
r.script_code
) in
1189 with Pycocci.Pycocciexception
->
1190 (pr2
("Failure in " ^
r.scr_rulename
);
1191 raise
Pycocci.Pycocciexception
)
1193 let ocaml_application mv ve
r =
1195 Run_ocamlcocci.run
mv ve
r.scr_rulename
r.script_code
;
1197 with e
-> (pr2
("Failure in " ^
r.scr_rulename
); raise e
)
1199 let apply_script_rule r cache newes e rules_that_have_matched
1200 rules_that_have_ever_matched script_application
=
1201 Common.profile_code
r.language
(fun () ->
1202 show_or_not_scr_rule_name r.scr_ruleid
;
1203 if not
(interpret_dependencies rules_that_have_matched
1204 !rules_that_have_ever_matched
r.scr_dependencies
)
1207 print_dependencies "dependencies for script not satisfied:"
1208 rules_that_have_matched
1209 !rules_that_have_ever_matched
r.scr_dependencies
;
1210 show_or_not_binding "in environment" e
;
1211 (cache
, (e
, rules_that_have_matched
)::newes
)
1215 let (_, mv, _) = r.scr_ast_rule
in
1217 (List.map
(function (n
,v
) -> (("virtual",n
),Ast_c.MetaIdVal
(v
,[])))
1218 !Flag.defined_virtual_env
) @ e
in
1219 let not_bound x
= not
(contains_binding ve x
) in
1220 (match List.filter
not_bound mv with
1222 let relevant_bindings =
1224 (function ((re
,rm
),_) ->
1225 List.exists
(function (_,(r,m
),_) -> r =*= re
&& m
=$
= rm
) mv)
1227 if List.mem
relevant_bindings cache
1231 "dependencies for script satisfied, but cached:"
1232 rules_that_have_matched
1233 !rules_that_have_ever_matched
1235 show_or_not_binding "in" e
;
1236 (* env might be bigger than what was cached against, so have to
1237 merge with newes anyway *)
1238 (cache
,merge_env [(e
, rules_that_have_matched
)] newes
)
1242 print_dependencies "dependencies for script satisfied:"
1243 rules_that_have_matched
1244 !rules_that_have_ever_matched
1246 show_or_not_binding "in" e
;
1247 let new_cache = relevant_bindings :: cache
in
1248 if script_application
mv ve r
1249 then (new_cache, merge_env [(e
, rules_that_have_matched
)] newes
)
1250 else (new_cache, newes
)
1253 (if !Flag_cocci.show_dependencies
1255 let m2c (_,(r,x
),_) = r^
"."^x
in
1256 pr2
(Printf.sprintf
"script not applied: %s not bound"
1257 (String.concat
", " (List.map
m2c unbound
))));
1258 (cache
, merge_env [(e
, rules_that_have_matched
)] newes
))
1261 let rec apply_cocci_rule r rules_that_have_ever_matched es
1262 (ccs:file_info list
ref) =
1263 Common.profile_code
r.rulename
(fun () ->
1264 show_or_not_rule_name r.ast_rule
r.ruleid
;
1265 show_or_not_ctl_text r.ctl
r.ast_rule
r.ruleid
;
1267 let reorganized_env =
1268 reassociate_positions
r.free_vars
r.negated_pos_vars
!es
in
1270 (* looping over the environments *)
1271 let (_,newes
(* envs for next round/rule *)) =
1273 (function (cache
,newes
) ->
1274 function ((e
,rules_that_have_matched
),relevant_bindings) ->
1275 if not
(interpret_dependencies rules_that_have_matched
1276 !rules_that_have_ever_matched
1281 ("dependencies for rule "^
r.rulename^
" not satisfied:")
1282 rules_that_have_matched
1283 !rules_that_have_ever_matched
r.dependencies
;
1284 show_or_not_binding "in environment" e
;
1287 [(e
+> List.filter
(fun (s,v
) -> List.mem
s r.used_after
),
1288 rules_that_have_matched
)]
1293 try List.assoc
relevant_bindings cache
1297 ("dependencies for rule "^
r.rulename^
" satisfied:")
1298 rules_that_have_matched
1299 !rules_that_have_ever_matched
1301 show_or_not_binding "in" e
;
1302 show_or_not_binding "relevant in" relevant_bindings;
1304 (* applying the rule *)
1305 (match r.ruletype
with
1307 (* looping over the functions and toplevel elements in
1310 (concat_headers_and_c !ccs +>
1311 List.fold_left
(fun children_e
(c
,f) ->
1314 (* does also some side effects on c and r *)
1316 process_a_ctl_a_env_a_toplevel
r
1317 relevant_bindings c
f in
1318 match processed with
1319 | None
-> children_e
1320 | Some newbindings
->
1323 (fun children_e newbinding
->
1324 if List.mem newbinding children_e
1326 else newbinding
:: children_e
)
1330 | Ast_cocci.Generated
->
1331 process_a_generated_a_env_a_toplevel
r
1332 relevant_bindings !ccs;
1335 let old_bindings_to_keep =
1337 (e
+> List.filter
(fun (s,v
) -> List.mem
s r.used_after
)) in
1339 if null
new_bindings
1342 (*use the old bindings, specialized to the used_after_list*)
1343 if !Flag_ctl.partial_match
1346 "Empty list of bindings, I will restart from old env\n";
1347 [(old_bindings_to_keep,rules_that_have_matched
)]
1350 (* combine the new bindings with the old ones, and
1351 specialize to the used_after_list *)
1352 let old_variables = List.map fst
old_bindings_to_keep in
1353 (* have to explicitly discard the inherited variables
1354 because we want the inherited value of the positions
1355 variables not the extended one created by
1356 reassociate_positions. want to reassociate freshly
1357 according to the free variables of each rule. *)
1358 let new_bindings_to_add =
1364 (* see comment before combine_pos *)
1365 (s,Ast_c.MetaPosValList
[]) -> false
1367 List.mem
s r.used_after
&&
1368 not
(List.mem
s old_variables)))) in
1370 (function new_binding_to_add
->
1373 old_bindings_to_keep new_binding_to_add
),
1374 r.rulename
::rules_that_have_matched
))
1375 new_bindings_to_add in
1376 ((relevant_bindings,new_bindings)::cache
,
1377 merge_env new_e newes
))
1378 ([],[]) reorganized_env in (* end iter es *)
1380 then Common.push2
r.rulename rules_that_have_ever_matched
;
1384 (* apply the tagged modifs and reparse *)
1385 if not
!Flag.sgrep_mode2
1386 then ccs := rebuild_info_c_and_headers !ccs r.isexp
)
1388 and reassociate_positions free_vars negated_pos_vars envs
=
1389 (* issues: isolate the bindings that are relevant to a given rule.
1390 separate out the position variables
1391 associate all of the position variables for a given set of relevant
1392 normal variable bindings with each set of relevant normal variable
1393 bindings. Goal: if eg if@p (E) matches in two places, then both inherited
1394 occurrences of E should see both bindings of p, not just its own.
1395 Otherwise, a position constraint for something that matches in two
1396 places will never be useful, because the position can always be
1397 different from the other one. *)
1401 List.filter
(function (x
,_) -> List.mem x free_vars
) e
)
1403 let splitted_relevant =
1404 (* separate the relevant variables into the non-position ones and the
1409 (function (non_pos
,pos
) ->
1410 function (v
,_) as x
->
1411 if List.mem v negated_pos_vars
1412 then (non_pos
,x
::pos
)
1413 else (x
::non_pos
,pos
))
1416 let splitted_relevant =
1418 (function (non_pos
,pos
) ->
1419 (List.sort compare non_pos
,List.sort compare pos
))
1420 splitted_relevant in
1423 (function non_pos
->
1425 if List.mem np non_pos
then non_pos
else np
::non_pos
)
1426 [] splitted_relevant in
1427 let extended_relevant =
1428 (* extend the position variables with the values found at other identical
1429 variable bindings *)
1431 (function non_pos
->
1434 (function (other_non_pos
,other_pos
) ->
1435 (* do we want equal? or just somehow compatible? eg non_pos
1436 binds only E, but other_non_pos binds both E and E1 *)
1437 non_pos
=*= other_non_pos
)
1438 splitted_relevant in
1442 (combine_pos negated_pos_vars
1443 (List.map
(function (_,x
) -> x
) others)))))
1446 (List.map
(function (non_pos
,_) -> List.assoc non_pos
extended_relevant)
1449 (* If the negated posvar is not bound at all, this function will
1450 nevertheless bind it to []. If we get rid of these bindings, then the
1451 matching of the term the position variable with the constraints will fail
1452 because some variables are unbound. So we let the binding be [] and then
1453 we will have to clean these up afterwards. This should be the only way
1454 that a position variable can have an empty binding. *)
1455 and combine_pos negated_pos_vars
others =
1461 (function positions ->
1462 function other_list
->
1464 match List.assoc posvar other_list
with
1465 Ast_c.MetaPosValList l1
->
1466 Common.union_set l1
positions
1467 | _ -> failwith
"bad value for a position variable"
1468 with Not_found
-> positions)
1470 (posvar
,Ast_c.MetaPosValList
positions))
1473 and process_a_generated_a_env_a_toplevel2
r env = function
1478 (rule
,_) when rule
=$
= r.rulename
-> false
1479 | (_,"ARGS") -> false
1482 let env_domain = List.map
(function (nm
,vl
) -> nm
) env in
1486 let (rl
,_) = Ast_cocci.get_meta_name md
in rl
=$
= r.rulename
)
1488 if Common.include_set
free_vars env_domain
1489 then Unparse_hrule.pp_rule
metavars r.ast_rule
env cfile
.full_fname
1490 | _ -> failwith
"multiple files not supported"
1492 and process_a_generated_a_env_a_toplevel rule
env ccs =
1493 Common.profile_code
"process_a_ctl_a_env_a_toplevel"
1494 (fun () -> process_a_generated_a_env_a_toplevel2 rule
env ccs)
1496 (* does side effects on C ast and on Cocci info rule *)
1497 and process_a_ctl_a_env_a_toplevel2
r e c
f =
1498 indent_do
(fun () ->
1499 show_or_not_celem "trying" c
.ast_c
;
1500 Flag.currentfile
:= Some
(f ^
":" ^
get_celem c
.ast_c
);
1501 let (trans_info, returned_any_states
, inherited_bindings
, newbindings
) =
1502 Common.save_excursion
Flag_ctl.loop_in_src_code
(fun () ->
1503 Flag_ctl.loop_in_src_code
:= !Flag_ctl.loop_in_src_code
||c
.contain_loop;
1505 (***************************************)
1506 (* !Main point! The call to the engine *)
1507 (***************************************)
1508 let model_ctl = CCI.model_for_ctl
r.dropped_isos
(Common.some c
.flow) e
1509 in CCI.mysat
model_ctl r.ctl
(r.used_after
, e
)
1512 if not returned_any_states
1515 show_or_not_celem "found match in" c
.ast_c
;
1516 show_or_not_trans_info trans_info;
1517 List.iter
(show_or_not_binding "out") newbindings
;
1519 r.was_matched
:= true;
1521 if not
(null
trans_info)
1523 c
.was_modified
:= true;
1525 (* les "more than one var in a decl" et "already tagged token"
1526 * font crasher coccinelle. Si on a 5 fichiers, donc on a 5
1527 * failed. Le try limite le scope des crashes pendant la
1528 * trasformation au fichier concerne. *)
1530 (* modify ast via side effect *)
1531 ignore
(Transformation_c.transform
r.rulename
r.dropped_isos
1532 inherited_bindings
trans_info (Common.some c
.flow));
1533 with Timeout
-> raise Timeout
| UnixExit i
-> raise
(UnixExit i
)
1536 Some
(List.map
(function x
-> x
@inherited_bindings
) newbindings
)
1540 and process_a_ctl_a_env_a_toplevel a b c
f=
1541 Common.profile_code
"process_a_ctl_a_env_a_toplevel"
1542 (fun () -> process_a_ctl_a_env_a_toplevel2 a b c
f)
1545 let rec bigloop2 rs
(ccs: file_info list
) =
1546 let init_es = [(Ast_c.emptyMetavarsBinding
,[])] in
1547 let es = ref init_es in
1548 let ccs = ref ccs in
1549 let rules_that_have_ever_matched = ref [] in
1551 (* looping over the rules *)
1552 rs
+> List.iter
(fun r ->
1554 InitialScriptRuleCocciInfo
r | FinalScriptRuleCocciInfo
r -> ()
1555 | ScriptRuleCocciInfo
r ->
1556 if !Flag_cocci.show_ctl_text
then begin
1557 Common.pr_xxxxxxxxxxxxxxxxx
();
1558 pr
("script: " ^
r.language
);
1559 Common.pr_xxxxxxxxxxxxxxxxx
();
1561 adjust_pp_with_indent
(fun () ->
1562 Format.force_newline
();
1563 let (l,mv,code
) = r.scr_ast_rule
in
1564 let deps = r.scr_dependencies
in
1565 Pretty_print_cocci.unparse
1566 (Ast_cocci.ScriptRule
("",l,deps,mv,code
)));
1569 if !Flag.show_misc
then print_endline
"RESULT =";
1573 (function (cache
, newes
) ->
1574 function (e
, rules_that_have_matched
) ->
1575 match r.language
with
1577 apply_script_rule r cache newes e rules_that_have_matched
1578 rules_that_have_ever_matched python_application
1580 apply_script_rule r cache newes e rules_that_have_matched
1581 rules_that_have_ever_matched ocaml_application
1583 concat_headers_and_c !ccs +> List.iter
(fun (c
,_) ->
1586 Printf.printf
"Flow: %s\r\nFlow!\r\n%!" c
.fullstring
);
1589 Printf.printf
"Unknown language: %s\n" r.language
;
1593 es := (if newes
= [] then init_es else newes
);
1594 | CocciRuleCocciInfo
r ->
1595 apply_cocci_rule r rules_that_have_ever_matched
1598 if !Flag.sgrep_mode2
1600 (* sgrep can lead to code that is not parsable, but we must
1601 * still call rebuild_info_c_and_headers to pretty print the
1602 * action (MINUS), so that later the diff will show what was
1603 * matched by sgrep. But we don't want the parsing error message
1604 * hence the following flag setting. So this code propably
1605 * will generate a NotParsedCorrectly for the matched parts
1606 * and the very final pretty print and diff will work
1608 Flag_parsing_c.verbose_parsing
:= false;
1609 ccs := rebuild_info_c_and_headers !ccs false
1611 !ccs (* return final C asts *)
1614 Common.profile_code
"bigloop" (fun () -> bigloop2 a b
)
1616 type init_final
= Initial
| Final
1618 let initial_final_bigloop2 ty rebuild
r =
1619 if !Flag_cocci.show_ctl_text
then
1621 Common.pr_xxxxxxxxxxxxxxxxx
();
1622 pr
((match ty
with Initial
-> "initial" | Final
-> "final") ^
": " ^
1624 Common.pr_xxxxxxxxxxxxxxxxx
();
1626 adjust_pp_with_indent
(fun () ->
1627 Format.force_newline
();
1628 Pretty_print_cocci.unparse
(rebuild
r.scr_ast_rule
r.scr_dependencies
));
1631 match r.language
with
1633 (* include_match makes no sense in an initial or final rule, although
1634 we have no way to prevent it *)
1635 let _ = apply_script_rule r [] [] [] [] (ref []) python_application in
1637 | "ocaml" when ty
= Initial
-> () (* nothing to do *)
1639 (* include_match makes no sense in an initial or final rule, although
1640 we have no way to prevent it *)
1641 let _ = apply_script_rule r [] [] [] [] (ref []) ocaml_application in
1644 Printf.printf
"Unknown language for initial/final script: %s\n"
1647 let initial_final_bigloop a b c
=
1648 Common.profile_code
"initial_final_bigloop"
1649 (fun () -> initial_final_bigloop2 a b c
)
1651 (*****************************************************************************)
1652 (* The main functions *)
1653 (*****************************************************************************)
1655 let pre_engine2 (coccifile
, isofile
) =
1656 show_or_not_cocci coccifile isofile
;
1657 Pycocci.set_coccifile coccifile
;
1660 if not
(Common.lfile_exists
isofile)
1662 pr2
("warning: Can't find default iso file: " ^
isofile);
1665 else Some
isofile in
1667 (* useful opti when use -dir *)
1668 let (metavars,astcocci
,
1669 free_var_lists
,negated_pos_lists
,used_after_lists
,
1670 positions_lists
,toks
,_) =
1671 sp_of_file coccifile
isofile in
1672 let ctls = ctls_of_ast astcocci used_after_lists positions_lists
in
1674 g_contain_typedmetavar := sp_contain_typed_metavar astcocci
;
1676 check_macro_in_sp_and_adjust toks
;
1678 show_or_not_ctl_tex astcocci
ctls;
1681 prepare_cocci ctls free_var_lists negated_pos_lists
1682 used_after_lists positions_lists
metavars astcocci
in
1684 let used_languages =
1686 (function languages
->
1688 ScriptRuleCocciInfo
(r) ->
1689 if List.mem
r.language languages
then
1692 r.language
::languages
1696 let initialized_languages =
1698 (function languages
->
1700 InitialScriptRuleCocciInfo
(r) ->
1701 (if List.mem
r.language languages
1704 ("double initializer found for "^
r.language
));
1705 if interpret_dependencies [] [] r.scr_dependencies
1708 initial_final_bigloop Initial
1709 (fun (x
,_,y
) -> fun deps ->
1710 Ast_cocci.InitialScriptRule
(r.scr_rulename
,x
,deps,y
))
1712 r.language
::languages
1718 let uninitialized_languages =
1720 (fun used
-> not
(List.mem used
initialized_languages))
1723 List.iter
(fun lgg
->
1724 initial_final_bigloop Initial
1725 (fun (x
,_,y
) -> fun deps ->
1726 Ast_cocci.InitialScriptRule
("",x
,deps,y
))
1727 (make_init "" (-1) lgg
Ast_cocci.NoDep
"");
1729 uninitialized_languages;
1734 Common.profile_code
"pre_engine" (fun () -> pre_engine2 a
)
1736 let full_engine2 (cocci_infos,toks
) cfiles
=
1738 show_or_not_cfiles cfiles
;
1740 (* optimisation allowing to launch coccinelle on all the drivers *)
1741 if !Flag_cocci.worth_trying_opt
&& not
(worth_trying cfiles toks
)
1747 pr2
("No matches found for " ^
(Common.join
" " toks
)
1748 ^
"\nSkipping:" ^
(Common.join
" " cfiles
)));
1749 cfiles
+> List.map
(fun s -> s, None
)
1754 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1755 if !Flag.show_misc
then pr
"let's go";
1756 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1758 let choose_includes =
1759 match !Flag_cocci.include_options
with
1760 Flag_cocci.I_UNSPECIFIED
->
1761 if !g_contain_typedmetavar
1762 then Flag_cocci.I_NORMAL_INCLUDES
1763 else Flag_cocci.I_NO_INCLUDES
1765 let c_infos = prepare_c cfiles
choose_includes in
1767 (* ! the big loop ! *)
1768 let c_infos'
= bigloop cocci_infos c_infos in
1770 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1771 if !Flag.show_misc
then pr
"Finished";
1772 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1773 if !Flag_ctl.graphical_trace
then gen_pdf_graph ();
1775 c_infos'
+> List.map
(fun c_or_h
->
1776 if !(c_or_h
.was_modified_once
)
1780 Common.new_temp_file
"cocci-output" ("-" ^ c_or_h
.fname
) in
1782 if c_or_h
.fkind
=*= Header
1783 then pr2
("a header file was modified: " ^ c_or_h
.fname
);
1785 (* and now unparse everything *)
1786 cfile_of_program (for_unparser c_or_h
.asts
) outfile;
1788 show_or_not_diff c_or_h
.fpath
outfile;
1791 if !Flag.sgrep_mode2
then None
else Some
outfile)
1793 else (c_or_h
.fpath
, None
))
1796 let full_engine a b
=
1797 Common.profile_code
"full_engine"
1798 (fun () -> let res = full_engine2 a b
in (*Gc.print_stat stderr; *)res)
1800 let post_engine2 (cocci_infos,_) =
1803 (function languages
->
1805 FinalScriptRuleCocciInfo
(r) ->
1806 (if List.mem
r.language languages
1807 then failwith
("double finalizer found for "^
r.language
));
1808 initial_final_bigloop Final
1809 (fun (x
,_,y
) -> fun deps ->
1810 Ast_cocci.FinalScriptRule
(r.scr_rulename
,x
,deps,y
))
1812 r.language
::languages
1818 Common.profile_code
"post_engine" (fun () -> post_engine2 a
)
1820 (*****************************************************************************)
1821 (* check duplicate from result of full_engine *)
1822 (*****************************************************************************)
1824 let check_duplicate_modif2 xs =
1825 (* opti: let groups = Common.groupBy (fun (a,resa) (b,resb) -> a =$= b) xs *)
1826 if !Flag_cocci.verbose_cocci
1827 then pr2
("Check duplication for " ^ i_to_s
(List.length
xs) ^
" files");
1829 let groups = Common.group_assoc_bykey_eff
xs in
1830 groups +> Common.map_filter
(fun (file, xs) ->
1832 | [] -> raise Impossible
1833 | [res] -> Some
(file, res)
1837 if not
(List.for_all
(fun res2
-> res2
=*= None
) xs)
1839 pr2
("different modification result for " ^
file);
1842 else Some
(file, None
)
1844 if not
(List.for_all
(fun res2
->
1848 let diff = Common.cmd_to_list
("diff -u -b -B "^
res^
" "^res2
)
1852 pr2
("different modification result for " ^
file);
1855 else Some
(file, Some
res)
1857 let check_duplicate_modif a
=
1858 Common.profile_code
"check_duplicate" (fun () -> check_duplicate_modif2 a
)