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.
26 * Copyright 2010, INRIA, University of Copenhagen
27 * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
28 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
29 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
30 * This file is part of Coccinelle.
32 * Coccinelle is free software: you can redistribute it and/or modify
33 * it under the terms of the GNU General Public License as published by
34 * the Free Software Foundation, according to version 2 of the License.
36 * Coccinelle is distributed in the hope that it will be useful,
37 * but WITHOUT ANY WARRANTY; without even the implied warranty of
38 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
39 * GNU General Public License for more details.
41 * You should have received a copy of the GNU General Public License
42 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
44 * The authors reserve the right to distribute this or future versions of
45 * Coccinelle under other licenses.
51 module CCI
= Ctlcocci_integration
52 module TAC
= Type_annoter_c
54 module Ast_to_flow
= Control_flow_c_build
56 (*****************************************************************************)
57 (* This file is a kind of driver. It gathers all the important functions
58 * from coccinelle in one place. The different entities in coccinelle are:
62 * - flow (contain nodes)
63 * - ctl (contain rule_elems)
64 * This file contains functions to transform one in another.
66 (*****************************************************************************)
68 (* --------------------------------------------------------------------- *)
70 (* --------------------------------------------------------------------- *)
71 let cprogram_of_file file
=
72 let (program2
, _stat
) = Parse_c.parse_c_and_cpp file
in
75 let cprogram_of_file_cached file
=
76 let (program2
, _stat
) = Parse_c.parse_cache file
in
77 if !Flag_cocci.ifdef_to_if
79 program2
+> Parse_c.with_program2
(fun asts
->
80 Cpp_ast_c.cpp_ifdef_statementize asts
84 let cfile_of_program program2_with_ppmethod outf
=
85 Unparse_c.pp_program program2_with_ppmethod outf
87 (* for memoization, contains only one entry, the one for the SP *)
88 let _hparse = Hashtbl.create
101
89 let _hctl = Hashtbl.create
101
91 (* --------------------------------------------------------------------- *)
93 (* --------------------------------------------------------------------- *)
94 let sp_of_file2 file iso
=
95 Common.memoized
_hparse (file
, iso
) (fun () ->
96 let (_
,xs
,_
,_
,_
,_
,_
) as res
= Parse_cocci.process file iso
false in
97 (match Prepare_ocamlcocci.prepare file xs
with
99 | Some ocaml_script_file
->
101 Prepare_ocamlcocci.load_file ocaml_script_file
;
102 if not
!Common.save_tmp_files
103 then Prepare_ocamlcocci.clean_file ocaml_script_file
);
105 let sp_of_file file iso
=
106 Common.profile_code
"parse cocci" (fun () -> sp_of_file2 file iso
)
109 (* --------------------------------------------------------------------- *)
111 (* --------------------------------------------------------------------- *)
112 let print_flow flow
=
113 Ograph_extended.print_ograph_mutable flow
"/tmp/test.dot" true
116 let ast_to_flow_with_error_messages2 x
=
118 try Ast_to_flow.ast_to_control_flow x
119 with Ast_to_flow.Error x
->
120 Ast_to_flow.report_error x
;
123 flowopt +> do_option
(fun flow
->
124 (* This time even if there is a deadcode, we still have a
125 * flow graph, so I can try the transformation and hope the
126 * deadcode will not bother us.
128 try Ast_to_flow.deadcode_detection flow
129 with Ast_to_flow.Error
(Ast_to_flow.DeadCode x
) ->
130 Ast_to_flow.report_error
(Ast_to_flow.DeadCode x
);
133 let ast_to_flow_with_error_messages a
=
134 Common.profile_code
"flow" (fun () -> ast_to_flow_with_error_messages2 a
)
137 (* --------------------------------------------------------------------- *)
139 (* --------------------------------------------------------------------- *)
141 let ctls_of_ast2 ast
(ua
,fua
,fuas
) pos
=
143 (function ast
-> function (ua
,(fua
,(fuas
,pos
))) ->
147 else Asttoctl2.asttoctl ast
(ua
,fua
,fuas
) pos
)
148 (Asttomember.asttomember ast ua
))
149 ast
(List.combine ua
(List.combine fua
(List.combine fuas pos
)))
151 let ctls_of_ast ast ua
=
152 Common.profile_code
"asttoctl2" (fun () -> ctls_of_ast2 ast ua
)
154 (*****************************************************************************)
155 (* Some debugging functions *)
156 (*****************************************************************************)
160 let show_or_not_cfile2 cfile
=
161 if !Flag_cocci.show_c
then begin
162 Common.pr2_xxxxxxxxxxxxxxxxx
();
163 pr2
("processing C file: " ^ cfile
);
164 Common.pr2_xxxxxxxxxxxxxxxxx
();
165 Common.command2
("cat " ^ cfile
);
167 let show_or_not_cfile a
=
168 Common.profile_code
"show_xxx" (fun () -> show_or_not_cfile2 a
)
170 let show_or_not_cfiles cfiles
= List.iter
show_or_not_cfile cfiles
173 let show_or_not_cocci2 coccifile isofile
=
174 if !Flag_cocci.show_cocci
then begin
175 Common.pr2_xxxxxxxxxxxxxxxxx
();
176 pr2
("processing semantic patch file: " ^ coccifile
);
177 isofile
+> (fun s
-> pr2
("with isos from: " ^ s
));
178 Common.pr2_xxxxxxxxxxxxxxxxx
();
179 Common.command2
("cat " ^ coccifile
);
182 let show_or_not_cocci a b
=
183 Common.profile_code
"show_xxx" (fun () -> show_or_not_cocci2 a b
)
185 (* ---------------------------------------------------------------------- *)
188 let fix_sgrep_diffs l
=
190 List.filter
(function s
-> (s
=~
"^\\+\\+\\+") || not
(s
=~
"^\\+")) l in
191 let l = List.rev
l in
192 (* adjust second number for + code *)
193 let rec loop1 n
= function
196 if s
=~
"^-" && not
(s
=~
"^---")
197 then s
:: loop1 (n
+1) ss
200 (match Str.split
(Str.regexp
" ") s
with
203 match Str.split
(Str.regexp
",") pl
with
206 | _
-> failwith
"bad + line information" in
207 let n2 = int_of_string
n2 in
208 (Printf.sprintf
"%s %s %s,%d %s" bef min n1
(n2-n
)
209 (String.concat
" " aft
))
211 | _
-> failwith
"bad @@ information")
212 else s
:: loop1 n ss
in
213 let rec loop2 n
= function
220 (match Str.split
(Str.regexp
" ") s
with
223 match (Str.split
(Str.regexp
",") min
,
224 Str.split
(Str.regexp
",") pl
) with
225 ([_
;m2
],[n1
;n2]) -> (m2
,n1
,n2)
226 | ([_
],[n1
;n2]) -> ("1",n1
,n2)
227 | ([_
;m2
],[n1
]) -> (m2
,n1
,"1")
228 | ([_
],[n1
]) -> ("1",n1
,"1")
229 | _
-> failwith
"bad -/+ line information" in
231 int_of_string
(String.sub
n1 1 ((String.length
n1)-1)) in
232 let m2 = int_of_string
m2 in
233 let n2 = int_of_string
n2 in
234 (Printf.sprintf
"%s %s +%d,%d %s" bef min
(n1-n
) n2
235 (String.concat
" " aft
))
236 :: loop2 (n
+(m2-n2)) ss
237 | _
-> failwith
"bad @@ information")
238 else s
:: loop2 n ss
in
239 loop2 0 (List.rev
(loop1 0 l))
241 let normalize_path file
=
243 if String.get file
0 = '
/'
then file
else (Sys.getcwd
()) ^
"/" ^ file
in
244 let elements = Str.split_delim
(Str.regexp
"/") fullpath in
245 let rec loop prev
= function
246 [] -> String.concat
"/" (List.rev prev
)
247 | "." :: rest
-> loop prev rest
250 x
::xs
-> loop xs rest
251 | _
-> failwith
"bad path")
252 | x
::rest
-> loop (x
::prev
) rest
in
255 let show_or_not_diff2 cfile outfile
=
256 if !Flag_cocci.show_diff
then begin
257 match Common.fst
(Compare_c.compare_to_original cfile outfile
) with
258 Compare_c.Correct
-> () (* diff only in spacing, etc *)
260 (* may need --strip-trailing-cr under windows *)
264 match !Flag_parsing_c.diff_lines
with
265 | None
-> "diff -u -p " ^ cfile ^
" " ^ outfile
266 | Some n
-> "diff -U "^n^
" -p "^cfile^
" "^outfile
in
268 let res = Common.cmd_to_list
line in
269 match (!Flag.patch
,res) with
270 (* create something that looks like the output of patch *)
271 (Some prefix
,minus_file
::plus_file
::rest
) ->
273 let lp = String.length
prefix in
274 if String.get
prefix (lp-1) = '
/'
275 then String.sub
prefix 0 (lp-1)
277 let drop_prefix file
=
278 let file = normalize_path file in
279 if Str.string_match
(Str.regexp
prefix) file 0
281 let lp = String.length
prefix in
282 let lf = String.length
file in
284 then String.sub
file lp (lf - lp)
287 (Printf.sprintf
"prefix %s doesn't match file %s"
291 (Printf.sprintf
"prefix %s doesn't match file %s"
294 match List.rev
(Str.split
(Str.regexp
" ") line) with
295 new_file
::old_file
::cmdrev
->
296 let old_base_file = drop_prefix old_file
in
301 (("/tmp/nothing"^
old_base_file)
302 :: old_file
:: cmdrev
))
306 (("b"^
old_base_file)::("a"^
old_base_file)::cmdrev
))
307 | _
-> failwith
"bad command" in
308 let (minus_line
,plus_line
) =
309 match (Str.split
(Str.regexp
"[ \t]") minus_file
,
310 Str.split
(Str.regexp
"[ \t]") plus_file
) with
311 ("---"::old_file
::old_rest
,"+++"::new_file
::new_rest
) ->
312 let old_base_file = drop_prefix old_file
in
314 then (minus_file
,"+++ /tmp/nothing"^
old_base_file)
317 ("---"::("a"^
old_base_file)::old_rest
),
319 ("+++"::("b"^
old_base_file)::new_rest
))
322 (Printf.sprintf
"bad diff header lines: %s %s"
323 (String.concat
":" l1
) (String.concat
":" l2
)) in
324 diff_line::minus_line
::plus_line
::rest
326 let xs = if !Flag.sgrep_mode2
then fix_sgrep_diffs xs else xs in
329 let show_or_not_diff a b
=
330 Common.profile_code
"show_xxx" (fun () -> show_or_not_diff2 a b
)
333 (* the derived input *)
335 let show_or_not_ctl_tex2 astcocci ctls
=
336 if !Flag_cocci.show_ctl_tex
then begin
337 Ctltotex.totex
("/tmp/__cocci_ctl.tex") astcocci ctls
;
338 Common.command2
("cd /tmp; latex __cocci_ctl.tex; " ^
339 "dvips __cocci_ctl.dvi -o __cocci_ctl.ps;" ^
340 "gv __cocci_ctl.ps &");
342 let show_or_not_ctl_tex a b
=
343 Common.profile_code
"show_xxx" (fun () -> show_or_not_ctl_tex2 a b
)
346 let show_or_not_rule_name ast rulenb
=
347 if !Flag_cocci.show_ctl_text
or !Flag.show_trying
or
348 !Flag.show_transinfo
or !Flag_cocci.show_binding_in_out
353 Ast_cocci.CocciRule
(nm
, (deps
, drops
, exists
), x
, _
, _
) -> nm
354 | _
-> i_to_s rulenb
in
355 Common.pr_xxxxxxxxxxxxxxxxx
();
357 Common.pr_xxxxxxxxxxxxxxxxx
()
360 let show_or_not_scr_rule_name rulenb
=
361 if !Flag_cocci.show_ctl_text
or !Flag.show_trying
or
362 !Flag.show_transinfo
or !Flag_cocci.show_binding_in_out
365 let name = i_to_s rulenb
in
366 Common.pr_xxxxxxxxxxxxxxxxx
();
367 pr
("script rule " ^
name ^
" = ");
368 Common.pr_xxxxxxxxxxxxxxxxx
()
371 let show_or_not_ctl_text2 ctl ast rulenb
=
372 if !Flag_cocci.show_ctl_text
then begin
374 adjust_pp_with_indent
(fun () ->
375 Format.force_newline
();
376 Pretty_print_cocci.print_plus_flag
:= true;
377 Pretty_print_cocci.print_minus_flag
:= true;
378 Pretty_print_cocci.unparse ast
;
383 adjust_pp_with_indent
(fun () ->
384 Format.force_newline
();
385 Pretty_print_engine.pp_ctlcocci
386 !Flag_cocci.show_mcodekind_in_ctl
!Flag_cocci.inline_let_ctl ctl
;
390 let show_or_not_ctl_text a b c
=
391 Common.profile_code
"show_xxx" (fun () -> show_or_not_ctl_text2 a b c
)
395 (* running information *)
396 let get_celem celem
: string =
398 Ast_c.Definition
({Ast_c.f_name
= namefuncs
;},_
) ->
399 Ast_c.str_of_name namefuncs
401 (Ast_c.DeclList
([{Ast_c.v_namei
= Some
(name, _
);}, _
], _
)) ->
402 Ast_c.str_of_name
name
405 let show_or_not_celem2 prelude celem
=
408 | Ast_c.Definition
({Ast_c.f_name
= namefuncs
},_
) ->
409 let funcs = Ast_c.str_of_name namefuncs
in
410 Flag.current_element
:= funcs;
411 (" function: ",funcs)
413 (Ast_c.DeclList
([{Ast_c.v_namei
= Some
(name,_
)}, _
], _
)) ->
414 let s = Ast_c.str_of_name
name in
415 Flag.current_element
:= s;
418 Flag.current_element
:= "something_else";
419 (" ","something else");
421 if !Flag.show_trying
then pr2
(prelude ^ tag ^ trying
)
423 let show_or_not_celem a b
=
424 Common.profile_code
"show_xxx" (fun () -> show_or_not_celem2 a b
)
427 let show_or_not_trans_info2 trans_info
=
428 (* drop witness tree indices for printing *)
430 List.map
(function (index
,trans_info) -> trans_info) trans_info in
431 if !Flag.show_transinfo
then begin
432 if null
trans_info then pr2
"transformation info is empty"
434 pr2
"transformation info returned:";
436 List.sort
(function (i1
,_
,_
) -> function (i2
,_
,_
) -> compare i1 i2
)
440 trans_info +> List.iter
(fun (i
, subst
, re
) ->
441 pr2
("transform state: " ^
(Common.i_to_s i
));
443 adjust_pp_with_indent_and_header
"with rule_elem: " (fun () ->
444 Pretty_print_cocci.print_plus_flag
:= true;
445 Pretty_print_cocci.print_minus_flag
:= true;
446 Pretty_print_cocci.rule_elem
"" re
;
448 adjust_pp_with_indent_and_header
"with binding: " (fun () ->
449 Pretty_print_engine.pp_binding subst
;
456 let show_or_not_trans_info a
=
457 Common.profile_code
"show_xxx" (fun () -> show_or_not_trans_info2 a
)
461 let show_or_not_binding2 s binding
=
462 if !Flag_cocci.show_binding_in_out
then begin
463 adjust_pp_with_indent_and_header
("binding " ^
s ^
" = ") (fun () ->
464 Pretty_print_engine.pp_binding binding
467 let show_or_not_binding a b
=
468 Common.profile_code
"show_xxx" (fun () -> show_or_not_binding2 a b
)
472 (*****************************************************************************)
473 (* Some helper functions *)
474 (*****************************************************************************)
476 let worth_trying cfiles tokens
=
477 (* drop the following line for a list of list by rules. since we don't
478 allow multiple minirules, all the tokens within a rule should be in
479 a single CFG entity *)
480 match (!Flag_cocci.windows
,tokens
) with
481 (true,_
) | (_
,None
) -> true
483 (* could also modify the code in get_constants.ml *)
484 let tokens = tokens +> List.map
(fun s ->
486 | _
when s =~
"^[A-Za-z_][A-Za-z_0-9]*$" ->
489 | _
when s =~
"^[A-Za-z_]" ->
492 | _
when s =~
".*[A-Za-z_]$" ->
497 let com = sprintf
"egrep -q '(%s)' %s" (join
"|" tokens) (join
" " cfiles
)
499 (match Sys.command
com with
500 | 0 (* success *) -> true
503 then Printf.printf
"grep failed: %s\n" com);
504 false (* no match, so not worth trying *))
506 let check_macro_in_sp_and_adjust = function
509 tokens +> List.iter
(fun s ->
510 if Hashtbl.mem
!Parse_c._defs
s
512 if !Flag_cocci.verbose_cocci
then begin
513 pr2
"warning: macro in semantic patch was in macro definitions";
514 pr2
("disabling macro expansion for " ^
s);
516 Hashtbl.remove
!Parse_c._defs
s
520 let contain_loop gopt
=
523 g#nodes#tolist
+> List.exists
(fun (xi
, node
) ->
524 Control_flow_c.extract_is_loop node
526 | None
-> true (* means nothing, if no g then will not model check *)
530 let sp_contain_typed_metavar_z toplevel_list_list
=
531 let bind x y
= x
or y
in
532 let option_default = false in
533 let mcode _ _
= option_default in
534 let donothing r k e
= k e
in
536 let expression r k e
=
537 match Ast_cocci.unwrap e
with
538 | Ast_cocci.MetaExpr
(_
,_
,_
,Some t
,_
,_
) -> true
539 | Ast_cocci.MetaExpr
(_
,_
,_
,_
,Ast_cocci.LocalID
,_
) -> true
544 Visitor_ast.combiner bind option_default
545 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
546 donothing donothing donothing donothing donothing
547 donothing expression donothing donothing donothing donothing donothing
548 donothing donothing donothing donothing donothing
550 toplevel_list_list
+>
552 (function (nm
,_
,rule
) ->
553 (List.exists
combiner.Visitor_ast.combiner_top_level rule
))
555 let sp_contain_typed_metavar rules
=
556 sp_contain_typed_metavar_z
560 Ast_cocci.CocciRule
(a
,b
,c
,d
,_
) -> (a
,b
,c
)
561 | _
-> failwith
"error in filter")
565 Ast_cocci.CocciRule
(a
,b
,c
,d
,Ast_cocci.Normal
) -> true
571 (* finding among the #include the one that we need to parse
572 * because they may contain useful type definition or because
573 * we may have to modify them
575 * For the moment we base in part our heuristic on the name of the file, e.g.
576 * serio.c is related we think to #include <linux/serio.h>
578 let rec search_include_path searchlist relpath
=
579 match searchlist
with
582 let file = Filename.concat hd relpath
in
583 if Sys.file_exists
file then
586 search_include_path tail relpath
588 let interpret_include_path relpath
=
590 match !Flag_cocci.include_path
with
594 search_include_path searchlist relpath
596 let (includes_to_parse
:
597 (Common.filename
* Parse_c.program2
) list
->
598 Flag_cocci.include_options
-> 'a
) = fun xs choose_includes
->
599 match choose_includes
with
600 Flag_cocci.I_UNSPECIFIED
-> failwith
"not possible"
601 | Flag_cocci.I_NO_INCLUDES
-> []
605 [Flag_cocci.I_ALL_INCLUDES
; Flag_cocci.I_REALLY_ALL_INCLUDES
] in
606 xs +> List.map
(fun (file, cs
) ->
607 let dir = Common.dirname
file in
609 cs
+> Common.map_filter
(fun (c
,_info_item
) ->
613 {Ast_c.i_include
= ((x
,ii
)); i_rel_pos
= info_h_pos
;}) ->
616 let relpath = Common.join
"/" xs in
617 let f = Filename.concat
dir (relpath) in
618 if (Sys.file_exists
f) then
621 if !Flag_cocci.relax_include_path
622 (* for our tests, all the files are flat in the current dir *)
624 let attempt2 = Filename.concat
dir (Common.last
xs) in
625 if not
(Sys.file_exists
attempt2) && all_includes
627 interpret_include_path relpath
630 if all_includes then interpret_include_path relpath
633 | Ast_c.NonLocal
xs ->
634 let relpath = Common.join
"/" xs in
636 Common.fileprefix
(Common.last
xs) =$
= Common.fileprefix
file
638 interpret_include_path relpath
640 | Ast_c.Weird _
-> None
644 +> (fun x
-> (List.rev
(Common.uniq
(List.rev x
)))) (*uniq keeps last*)
646 let rec interpret_dependencies local global
= function
647 Ast_cocci.Dep
s -> List.mem
s local
648 | Ast_cocci.AntiDep
s ->
649 (if !Flag_ctl.steps
!= None
650 then failwith
"steps and ! dependency incompatible");
651 not
(List.mem
s local
)
652 | Ast_cocci.EverDep
s -> List.mem
s global
653 | Ast_cocci.NeverDep
s ->
654 (if !Flag_ctl.steps
!= None
655 then failwith
"steps and ! dependency incompatible");
656 not
(List.mem
s global
)
657 | Ast_cocci.AndDep
(s1
,s2
) ->
658 (interpret_dependencies local global s1
) &&
659 (interpret_dependencies local global s2
)
660 | Ast_cocci.OrDep
(s1
,s2
) ->
661 (interpret_dependencies local global s1
) or
662 (interpret_dependencies local global s2
)
663 | Ast_cocci.NoDep
-> true
664 | Ast_cocci.FailDep
-> false
666 let rec print_dependencies str local global dep
=
667 if !Flag_cocci.show_dependencies
672 let rec loop = function
673 Ast_cocci.Dep
s | Ast_cocci.AntiDep
s ->
674 if not
(List.mem
s !seen)
678 then pr2
(s^
" satisfied")
679 else pr2
(s^
" not satisfied");
682 | Ast_cocci.EverDep
s | Ast_cocci.NeverDep
s ->
683 if not
(List.mem
s !seen)
687 then pr2
(s^
" satisfied")
688 else pr2
(s^
" not satisfied");
691 | Ast_cocci.AndDep
(s1
,s2
) ->
694 | Ast_cocci.OrDep
(s1
,s2
) ->
697 | Ast_cocci.NoDep
-> ()
698 | Ast_cocci.FailDep
-> pr2
"False not satisfied" in
702 (* --------------------------------------------------------------------- *)
703 (* #include relative position in the file *)
704 (* --------------------------------------------------------------------- *)
706 (* compute the set of new prefixes
708 * "a/b/x"; (* in fact it is now a list of string so ["a";"b";"x"] *)
712 * it would give
for the first element
713 * ""; "a"; "a/b"; "a/b/x"
717 * update
: if the
include is inside a ifdef a put nothing
. cf
-test incl
.
718 * this is because we dont want code added inside ifdef
.
721 let compute_new_prefixes xs =
722 xs +> Common.map_withenv
(fun already
xs ->
723 let subdirs_prefixes = Common.inits
xs in
724 let new_first = subdirs_prefixes +> List.filter
(fun x
->
725 not
(List.mem x already
)
734 (* does via side effect on the ref in the Include in Ast_c *)
735 let rec update_include_rel_pos cs
=
736 let only_include = cs
+> Common.map_filter
(fun c
->
738 | Ast_c.CppTop
(Ast_c.Include
{Ast_c.i_include
= ((x
,_
));
740 i_is_in_ifdef
= inifdef
}) ->
742 | Ast_c.Weird _
-> None
751 let (locals
, nonlocals
) =
752 only_include +> Common.partition_either
(fun (c
, aref
) ->
754 | Ast_c.Local x
-> Left
(x
, aref
)
755 | Ast_c.NonLocal x
-> Right
(x
, aref
)
756 | Ast_c.Weird x
-> raise Impossible
759 update_rel_pos_bis locals
;
760 update_rel_pos_bis nonlocals
;
762 and update_rel_pos_bis
xs =
763 let xs'
= List.map fst
xs in
764 let the_first = compute_new_prefixes xs'
in
765 let the_last = List.rev
(compute_new_prefixes (List.rev
xs'
)) in
766 let merged = Common.zip
xs (Common.zip
the_first the_last) in
767 merged +> List.iter
(fun ((x
, aref
), (the_first, the_last)) ->
770 Ast_c.first_of
= the_first;
771 Ast_c.last_of
= the_last;
776 (*****************************************************************************)
777 (* All the information needed around the C elements and Cocci rules *)
778 (*****************************************************************************)
780 type toplevel_c_info
= {
781 ast_c
: Ast_c.toplevel
; (* contain refs so can be modified *)
782 tokens_c
: Parser_c.token list
;
785 flow
: Control_flow_c.cflow
option; (* it's the "fixed" flow *)
788 env_typing_before
: TAC.environment
;
789 env_typing_after
: TAC.environment
;
791 was_modified
: bool ref;
798 dependencies
: Ast_cocci.dependency
;
799 used_after
: Ast_cocci.meta_name list
;
801 was_matched
: bool ref;
804 type toplevel_cocci_info_script_rule
= {
807 (Ast_cocci.script_meta_name
* Ast_cocci.meta_name
*
808 Ast_cocci.metavar
) list
*
809 Ast_cocci.meta_name list
(*fresh vars*) *
813 scr_rule_info
: rule_info
;
816 type toplevel_cocci_info_cocci_rule
= {
817 ctl
: Lib_engine.ctlcocci
* (CCI.pred list list
);
818 metavars
: Ast_cocci.metavar list
;
819 ast_rule
: Ast_cocci.rule
;
820 isexp
: bool; (* true if + code is an exp, only for Flag.make_hrule *)
822 (* There are also some hardcoded rule names in parse_cocci.ml:
823 * let reserved_names = ["all";"optional_storage";"optional_qualifier"]
825 dropped_isos
: string list
;
826 free_vars
: Ast_cocci.meta_name list
;
827 negated_pos_vars
: Ast_cocci.meta_name list
;
828 positions
: Ast_cocci.meta_name list
;
830 ruletype
: Ast_cocci.ruletype
;
832 rule_info
: rule_info
;
835 type toplevel_cocci_info
=
836 ScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
837 | InitialScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
838 | FinalScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
839 | CocciRuleCocciInfo
of toplevel_cocci_info_cocci_rule
841 type cocci_info
= toplevel_cocci_info list
* string list
option (* tokens *)
843 type kind_file
= Header
| Source
847 was_modified_once
: bool ref;
848 asts
: toplevel_c_info list
;
853 let g_contain_typedmetavar = ref false
856 let last_env_toplevel_c_info xs =
857 (Common.last
xs).env_typing_after
859 let concat_headers_and_c (ccs
: file_info list
)
860 : (toplevel_c_info
* string) list
=
861 (List.concat
(ccs
+> List.map
(fun x
->
862 x
.asts
+> List.map
(fun x'
->
865 let for_unparser xs =
866 xs +> List.map
(fun x
->
867 (x
.ast_c
, (x
.fullstring
, x
.tokens_c
)), Unparse_c.PPviastr
870 let gen_pdf_graph () =
871 (Ctl_engine.get_graph_files
()) +> List.iter
(fun outfile
->
872 Printf.printf
"Generation of %s%!" outfile
;
873 let filename_stack = Ctl_engine.get_graph_comp_files outfile
in
874 List.iter
(fun filename
->
875 ignore
(Unix.system
("dot " ^ filename ^
" -Tpdf -o " ^ filename ^
".pdf;"))
877 let (head
,tail
) = (List.hd
filename_stack, List.tl
filename_stack) in
878 ignore
(Unix.system
("cp " ^ head ^
".pdf " ^ outfile ^
".pdf;"));
879 tail
+> List.iter
(fun filename
->
880 ignore
(Unix.system
("mv " ^ outfile ^
".pdf /tmp/tmp.pdf;"));
881 ignore
(Unix.system
("pdftk " ^ filename ^
".pdf /tmp/tmp.pdf cat output " ^ outfile ^
".pdf"));
883 ignore
(Unix.system
("rm /tmp/tmp.pdf;"));
884 List.iter
(fun filename
->
885 ignore
(Unix.system
("rm " ^ filename ^
" " ^ filename ^
".pdf;"))
887 Printf.printf
" - Done\n")
889 let local_python_code =
890 "from coccinelle import *\n"
893 "import coccinelle\n"^
895 "import coccilib.org\n"^
896 "import coccilib.report\n" ^
900 let make_init lang code rule_info
=
903 scr_ast_rule
= (lang
, mv, [], code
);
905 script_code
= (if lang
= "python" then python_code else "") ^code
;
906 scr_rule_info
= rule_info
;
909 (* --------------------------------------------------------------------- *)
910 let prepare_cocci ctls free_var_lists negated_pos_lists
911 (ua
,fua
,fuas
) positions_list metavars astcocci
=
913 let gathered = Common.index_list_1
914 (zip
(zip
(zip
(zip
(zip
(zip
(zip
(zip ctls metavars
) astcocci
)
916 negated_pos_lists
) ua
) fua
) fuas
) positions_list
)
919 (fun (((((((((ctl_toplevel_list
,metavars
),ast
),free_var_list
),
920 negated_pos_list
),ua
),fua
),fuas
),positions_list
),rulenb
) ->
922 let build_rule_info rulename deps
=
923 {rulename
= rulename
;
925 used_after
= (List.hd ua
) @ (List.hd fua
);
927 was_matched
= ref false;} in
929 let is_script_rule r
=
931 Ast_cocci.ScriptRule _
932 | Ast_cocci.InitialScriptRule _
| Ast_cocci.FinalScriptRule _
-> true
935 if not
(List.length ctl_toplevel_list
=|= 1) && not
(is_script_rule ast
)
936 then failwith
"not handling multiple minirules";
939 Ast_cocci.ScriptRule
(name,lang
,deps
,mv,script_vars
,code
) ->
942 scr_ast_rule
= (lang
, mv, script_vars
, code
);
945 scr_rule_info
= build_rule_info name deps
;
947 in ScriptRuleCocciInfo
r
948 | Ast_cocci.InitialScriptRule
(name,lang
,deps
,code
) ->
949 let r = make_init lang code
(build_rule_info name deps
) in
950 InitialScriptRuleCocciInfo
r
951 | Ast_cocci.FinalScriptRule
(name,lang
,deps
,code
) ->
955 scr_ast_rule
= (lang
, mv, [], code
);
958 scr_rule_info
= build_rule_info name deps
;
960 in FinalScriptRuleCocciInfo
r
961 | Ast_cocci.CocciRule
962 (rulename
,(dependencies
,dropped_isos
,z
),restast
,isexp
,ruletype
) ->
965 ctl
= List.hd ctl_toplevel_list
;
968 isexp
= List.hd isexp
;
969 dropped_isos
= dropped_isos
;
970 free_vars
= List.hd free_var_list
;
971 negated_pos_vars
= List.hd negated_pos_list
;
972 positions
= List.hd positions_list
;
974 rule_info
= build_rule_info rulename dependencies
;
978 (* --------------------------------------------------------------------- *)
980 let build_info_program cprogram env
=
982 let (cs
, parseinfos
) =
983 Common.unzip cprogram
in
986 parseinfos
+> List.map
(fun (s,toks
) -> toks
) +> List.flatten
in
988 (* I use cs' but really annotate_xxx work by doing side effects on cs *)
990 Comment_annotater_c.annotate_program
alltoks cs in
992 Type_annoter_c.annotate_program env
(*!g_contain_typedmetavar*) cs'
995 zip
cs_with_envs parseinfos
+> List.map
(fun ((c
, (enva
,envb
)), parseinfo
)->
996 let (fullstr
, tokens) = parseinfo
in
999 ast_to_flow_with_error_messages c
+>
1000 Common.map_option
(fun flow ->
1001 let flow = Ast_to_flow.annotate_loop_nodes
flow in
1003 (* remove the fake nodes for julia *)
1004 let fixed_flow = CCI.fix_flow_ctl
flow in
1006 if !Flag_cocci.show_flow
then print_flow fixed_flow;
1007 if !Flag_cocci.show_before_fixed_flow
then print_flow flow;
1014 ast_c
= c
; (* contain refs so can be modified *)
1016 fullstring
= fullstr
;
1020 contain_loop = contain_loop flow;
1022 env_typing_before
= enva
;
1023 env_typing_after
= envb
;
1025 was_modified
= ref false;
1031 (* Optimisation. Try not unparse/reparse the whole file when have modifs *)
1032 let rebuild_info_program cs file isexp
=
1033 cs +> List.map
(fun c
->
1034 if !(c
.was_modified
)
1036 let file = Common.new_temp_file
"cocci_small_output" ".c" in
1038 [(c
.ast_c
, (c
.fullstring
, c
.tokens_c
)), Unparse_c.PPnormal
]
1041 (* Common.command2 ("cat " ^ file); *)
1042 let cprogram = cprogram_of_file file in
1043 let xs = build_info_program cprogram c
.env_typing_before
in
1045 (* TODO: assert env has not changed,
1046 * if yes then must also reparse what follows even if not modified.
1047 * Do that only if contain_typedmetavar of course, so good opti.
1049 (* Common.list_init xs *) (* get rid of the FinalDef *)
1055 let rebuild_info_c_and_headers ccs isexp
=
1056 ccs
+> List.iter
(fun c_or_h
->
1057 if c_or_h
.asts
+> List.exists
(fun c
-> !(c
.was_modified
))
1058 then c_or_h
.was_modified_once
:= true;
1060 ccs
+> List.map
(fun c_or_h
->
1063 rebuild_info_program c_or_h
.asts c_or_h
.full_fname isexp
}
1066 let rec prepare_h seen env hpath choose_includes
: file_info list
=
1067 if not
(Common.lfile_exists hpath
)
1070 pr2
("TYPE: header " ^ hpath ^
" not found");
1075 let h_cs = cprogram_of_file_cached hpath
in
1076 let local_includes =
1077 if choose_includes
=*= Flag_cocci.I_REALLY_ALL_INCLUDES
1080 (function x
-> not
(List.mem x
!seen))
1081 (includes_to_parse
[(hpath
,h_cs)] choose_includes
)
1083 seen := local_includes @ !seen;
1086 (List.map
(function x
-> prepare_h seen env x choose_includes
)
1088 let info_h_cs = build_info_program h_cs !env
in
1092 else last_env_toplevel_c_info info_h_cs;
1095 fname
= Common.basename hpath
;
1098 was_modified_once
= ref false;
1104 let prepare_c files choose_includes
: file_info list
=
1105 let cprograms = List.map
cprogram_of_file_cached files
in
1106 let includes = includes_to_parse
(zip files
cprograms) choose_includes
in
1107 let seen = ref includes in
1109 (* todo?: may not be good to first have all the headers and then all the c *)
1110 let env = ref !TAC.initial_env
in
1114 List.map
(function hpath
-> prepare_h seen env hpath choose_includes
) +>
1118 (zip files
cprograms) +>
1120 (function (file, cprogram) ->
1121 (* todo?: don't update env ? *)
1122 let cs = build_info_program cprogram !env in
1123 (* we do that only for the c, not for the h *)
1124 ignore
(update_include_rel_pos (cs +> List.map
(fun x
-> x
.ast_c
)));
1126 fname
= Common.basename
file;
1129 was_modified_once
= ref false;
1136 (*****************************************************************************)
1137 (* Processing the ctls and toplevel C elements *)
1138 (*****************************************************************************)
1140 (* The main algorithm =~
1141 * The algorithm is roughly:
1142 * for_all ctl rules in SP
1143 * for_all minirule in rule (no more)
1144 * for_all binding (computed during previous phase)
1145 * for_all C elements
1146 * match control flow of function vs minirule
1147 * with the binding and update the set of possible
1148 * bindings, and returned the possibly modified function.
1149 * pretty print modified C elements and reparse it.
1152 * On ne prends que les newbinding ou returned_any_state est vrai.
1153 * Si ca ne donne rien, on prends ce qu'il y avait au depart.
1154 * Mais au nouveau depart de quoi ?
1155 * - si ca donne rien apres avoir traité toutes les fonctions avec ce binding ?
1156 * - ou alors si ca donne rien, apres avoir traité toutes les fonctions
1157 * avec tous les bindings du round d'avant ?
1159 * Julia pense qu'il faut prendre la premiere solution.
1160 * Example: on a deux environnements candidats, E1 et E2 apres avoir traité
1161 * la regle ctl 1. On arrive sur la regle ctl 2.
1162 * E1 ne donne rien pour la regle 2, on garde quand meme E1 pour la regle 3.
1163 * E2 donne un match a un endroit et rend E2' alors on utilise ca pour
1166 * I have not to look at used_after_list to decide to restart from
1167 * scratch. I just need to look if the binding list is empty.
1168 * Indeed, let's suppose that a SP have 3 regions/rules. If we
1169 * don't find a match for the first region, then if this first
1170 * region does not bind metavariable used after, that is if
1171 * used_after_list is empty, then mysat(), even if does not find a
1172 * match, will return a Left, with an empty transformation_info,
1173 * and so current_binding will grow. On the contrary if the first
1174 * region must bind some metavariables used after, and that we
1175 * dont find any such region, then mysat() will returns lots of
1176 * Right, and current_binding will not grow, and so we will have
1177 * an empty list of binding, and we will catch such a case.
1179 * opti: julia says that because the binding is
1180 * determined by the used_after_list, the items in the list
1181 * are kind of sorted, so could optimise the insert_set operations.
1185 (* r(ule), c(element in C code), e(nvironment) *)
1188 let rec loop k
= function
1192 then Some
(x
, function n
-> k
(n
:: xs))
1193 else loop (function vs
-> k
(x
:: vs
)) xs in
1194 loop (function x
-> x
) l
1196 let merge_env new_e old_e
=
1199 (function (ext
,old_e
) ->
1200 function (e
,rules
) as elem
->
1201 match findk (function (e1
,_
) -> e
=*= e1
) old_e
with
1202 None
-> (elem
:: ext
,old_e
)
1203 | Some
((_
,old_rules
),k
) ->
1204 (ext
,k
(e
,Common.union_set rules old_rules
)))
1206 old_e
@ (List.rev ext
)
1208 let contains_binding e
(_
,(r,m
),_
) =
1210 let _ = List.find
(function ((re
, rm
), _) -> r =*= re
&& m
=$
= rm
) e
in
1212 with Not_found
-> false
1214 let python_application mv ve script_vars
r =
1218 ((Some x
,None
),y
,z
) -> (x
,y
,z
)
1221 (Printf.sprintf
"unexpected ast metavar in rule %s"
1222 r.scr_rule_info
.rulename
))
1225 Pycocci.build_classes
(List.map
(function (x
,y
) -> x
) ve
);
1226 Pycocci.construct_variables
mv ve
;
1227 Pycocci.construct_script_variables script_vars
;
1228 let _ = Pycocci.pyrun_simplestring
(local_python_code ^
r.script_code
) in
1229 if !Pycocci.inc_match
1230 then Some
(Pycocci.retrieve_script_variables script_vars
)
1232 with Pycocci.Pycocciexception
->
1233 (pr2
("Failure in " ^
r.scr_rule_info
.rulename
);
1234 raise
Pycocci.Pycocciexception
)
1236 let ocaml_application mv ve script_vars
r =
1239 Run_ocamlcocci.run
mv ve script_vars
1240 r.scr_rule_info
.rulename
r.script_code
in
1241 if !Coccilib.inc_match
1242 then Some
script_vals
1244 with e
-> (pr2
("Failure in " ^
r.scr_rule_info
.rulename
); raise e
)
1246 let apply_script_rule r cache newes e rules_that_have_matched
1247 rules_that_have_ever_matched script_application
=
1248 Common.profile_code
r.language
(fun () ->
1249 show_or_not_scr_rule_name r.scr_rule_info
.ruleid
;
1250 if not
(interpret_dependencies rules_that_have_matched
1251 !rules_that_have_ever_matched
r.scr_rule_info
.dependencies
)
1254 print_dependencies "dependencies for script not satisfied:"
1255 rules_that_have_matched
1256 !rules_that_have_ever_matched
r.scr_rule_info
.dependencies
;
1257 show_or_not_binding "in environment" e
;
1258 (cache
, (e
, rules_that_have_matched
)::newes
)
1262 let (_, mv, script_vars
, _) = r.scr_ast_rule
in
1264 (List.map
(function (n
,v
) -> (("virtual",n
),Ast_c.MetaIdVal
(v
,[])))
1265 !Flag.defined_virtual_env
) @ e
in
1266 let not_bound x
= not
(contains_binding ve x
) in
1267 (match List.filter
not_bound mv with
1269 let relevant_bindings =
1271 (function ((re
,rm
),_) ->
1272 List.exists
(function (_,(r,m
),_) -> r =*= re
&& m
=$
= rm
) mv)
1275 match List.assoc
relevant_bindings cache
with
1276 None
-> (cache
,newes
)
1277 | Some
script_vals ->
1279 "dependencies for script satisfied, but cached:"
1280 rules_that_have_matched
1281 !rules_that_have_ever_matched
1282 r.scr_rule_info
.dependencies
;
1283 show_or_not_binding "in" e
;
1284 (* env might be bigger than what was cached against, so have to
1285 merge with newes anyway *)
1286 let new_e = (List.combine script_vars
script_vals) @ e
in
1290 (fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1291 (cache
,merge_env [(new_e, rules_that_have_matched
)] newes
)
1294 print_dependencies "dependencies for script satisfied:"
1295 rules_that_have_matched
1296 !rules_that_have_ever_matched
1297 r.scr_rule_info
.dependencies
;
1298 show_or_not_binding "in" e
;
1299 match script_application
mv ve script_vars
r with
1301 (* failure means we should drop e, no new bindings *)
1302 (((relevant_bindings,None
) :: cache
), newes
)
1303 | Some
script_vals ->
1305 List.map
(function x
-> Ast_c.MetaIdVal
(x
,[]))
1308 (List.combine script_vars
script_vals) @ e
in
1312 (fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1313 r.scr_rule_info
.was_matched
:= true;
1314 (((relevant_bindings,Some
script_vals) :: cache
),
1317 r.scr_rule_info
.rulename
:: rules_that_have_matched
)]
1321 (if !Flag_cocci.show_dependencies
1323 let m2c (_,(r,x
),_) = r^
"."^x
in
1324 pr2
(Printf.sprintf
"script not applied: %s not bound"
1325 (String.concat
", " (List.map
m2c unbound
))));
1329 (fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1330 (cache
, merge_env [(e, rules_that_have_matched
)] newes
))
1333 let rec apply_cocci_rule r rules_that_have_ever_matched es
1334 (ccs
:file_info list
ref) =
1335 Common.profile_code
r.rule_info
.rulename
(fun () ->
1336 show_or_not_rule_name r.ast_rule
r.rule_info
.ruleid
;
1337 show_or_not_ctl_text r.ctl
r.ast_rule
r.rule_info
.ruleid
;
1339 let reorganized_env =
1340 reassociate_positions
r.free_vars
r.negated_pos_vars
!es
in
1342 (* looping over the environments *)
1343 let (_,newes
(* envs for next round/rule *)) =
1345 (function (cache
,newes
) ->
1346 function ((e,rules_that_have_matched
),relevant_bindings) ->
1347 if not
(interpret_dependencies rules_that_have_matched
1348 !rules_that_have_ever_matched
1349 r.rule_info
.dependencies
)
1353 ("dependencies for rule "^
r.rule_info
.rulename^
1355 rules_that_have_matched
1356 !rules_that_have_ever_matched
r.rule_info
.dependencies
;
1357 show_or_not_binding "in environment" e;
1362 (fun (s,v
) -> List.mem
s r.rule_info
.used_after
),
1363 rules_that_have_matched
)]
1368 try List.assoc
relevant_bindings cache
1372 ("dependencies for rule "^
r.rule_info
.rulename^
1374 rules_that_have_matched
1375 !rules_that_have_ever_matched
1376 r.rule_info
.dependencies
;
1377 show_or_not_binding "in" e;
1378 show_or_not_binding "relevant in" relevant_bindings;
1380 (* applying the rule *)
1381 (match r.ruletype
with
1383 (* looping over the functions and toplevel elements in
1386 (concat_headers_and_c !ccs
+>
1387 List.fold_left
(fun children_e
(c
,f) ->
1390 (* does also some side effects on c and r *)
1392 process_a_ctl_a_env_a_toplevel
r
1393 relevant_bindings c
f in
1394 match processed with
1395 | None
-> children_e
1396 | Some newbindings
->
1399 (fun children_e newbinding
->
1400 if List.mem newbinding children_e
1402 else newbinding
:: children_e
)
1406 | Ast_cocci.Generated
->
1407 process_a_generated_a_env_a_toplevel
r
1408 relevant_bindings !ccs
;
1411 let old_bindings_to_keep =
1415 (fun (s,v
) -> List.mem
s r.rule_info
.used_after
)) in
1417 if null
new_bindings
1420 (*use the old bindings, specialized to the used_after_list*)
1421 if !Flag_ctl.partial_match
1424 "Empty list of bindings, I will restart from old env\n";
1425 [(old_bindings_to_keep,rules_that_have_matched
)]
1428 (* combine the new bindings with the old ones, and
1429 specialize to the used_after_list *)
1430 let old_variables = List.map fst
old_bindings_to_keep in
1431 (* have to explicitly discard the inherited variables
1432 because we want the inherited value of the positions
1433 variables not the extended one created by
1434 reassociate_positions. want to reassociate freshly
1435 according to the free variables of each rule. *)
1436 let new_bindings_to_add =
1442 (* see comment before combine_pos *)
1443 (s,Ast_c.MetaPosValList
[]) -> false
1445 List.mem
s r.rule_info
.used_after
&&
1446 not
(List.mem
s old_variables)))) in
1448 (function new_binding_to_add
->
1451 old_bindings_to_keep new_binding_to_add
),
1452 r.rule_info
.rulename
::rules_that_have_matched
))
1453 new_bindings_to_add in
1454 ((relevant_bindings,new_bindings)::cache
,
1455 merge_env new_e newes
))
1456 ([],[]) reorganized_env in (* end iter es *)
1457 if !(r.rule_info
.was_matched
)
1458 then Common.push2
r.rule_info
.rulename rules_that_have_ever_matched
;
1462 (* apply the tagged modifs and reparse *)
1463 if not
!Flag.sgrep_mode2
1464 then ccs
:= rebuild_info_c_and_headers !ccs
r.isexp
)
1466 and reassociate_positions free_vars negated_pos_vars envs
=
1467 (* issues: isolate the bindings that are relevant to a given rule.
1468 separate out the position variables
1469 associate all of the position variables for a given set of relevant
1470 normal variable bindings with each set of relevant normal variable
1471 bindings. Goal: if eg if@p (E) matches in two places, then both inherited
1472 occurrences of E should see both bindings of p, not just its own.
1473 Otherwise, a position constraint for something that matches in two
1474 places will never be useful, because the position can always be
1475 different from the other one. *)
1479 List.filter
(function (x
,_) -> List.mem x free_vars
) e)
1481 let splitted_relevant =
1482 (* separate the relevant variables into the non-position ones and the
1487 (function (non_pos
,pos
) ->
1488 function (v
,_) as x
->
1489 if List.mem v negated_pos_vars
1490 then (non_pos
,x
::pos
)
1491 else (x
::non_pos
,pos
))
1494 let splitted_relevant =
1496 (function (non_pos
,pos
) ->
1497 (List.sort compare non_pos
,List.sort compare pos
))
1498 splitted_relevant in
1501 (function non_pos
->
1503 if List.mem np non_pos
then non_pos
else np
::non_pos
)
1504 [] splitted_relevant in
1505 let extended_relevant =
1506 (* extend the position variables with the values found at other identical
1507 variable bindings *)
1509 (function non_pos
->
1512 (function (other_non_pos
,other_pos
) ->
1513 (* do we want equal? or just somehow compatible? eg non_pos
1514 binds only E, but other_non_pos binds both E and E1 *)
1515 non_pos
=*= other_non_pos
)
1516 splitted_relevant in
1520 (combine_pos negated_pos_vars
1521 (List.map
(function (_,x
) -> x
) others)))))
1524 (List.map
(function (non_pos
,_) -> List.assoc non_pos
extended_relevant)
1527 (* If the negated posvar is not bound at all, this function will
1528 nevertheless bind it to []. If we get rid of these bindings, then the
1529 matching of the term the position variable with the constraints will fail
1530 because some variables are unbound. So we let the binding be [] and then
1531 we will have to clean these up afterwards. This should be the only way
1532 that a position variable can have an empty binding. *)
1533 and combine_pos negated_pos_vars
others =
1539 (function positions ->
1540 function other_list
->
1542 match List.assoc posvar other_list
with
1543 Ast_c.MetaPosValList l1
->
1544 Common.union_set l1
positions
1545 | _ -> failwith
"bad value for a position variable"
1546 with Not_found
-> positions)
1548 (posvar
,Ast_c.MetaPosValList
positions))
1551 and process_a_generated_a_env_a_toplevel2
r env = function
1556 (rule
,_) when rule
=$
= r.rule_info
.rulename
-> false
1557 | (_,"ARGS") -> false
1560 let env_domain = List.map
(function (nm
,vl
) -> nm
) env in
1564 let (rl
,_) = Ast_cocci.get_meta_name md
in rl
=$
= r.rule_info
.rulename
)
1566 if Common.include_set
free_vars env_domain
1567 then Unparse_hrule.pp_rule
metavars r.ast_rule
env cfile
.full_fname
1568 | _ -> failwith
"multiple files not supported"
1570 and process_a_generated_a_env_a_toplevel rule
env ccs
=
1571 Common.profile_code
"process_a_ctl_a_env_a_toplevel"
1572 (fun () -> process_a_generated_a_env_a_toplevel2 rule
env ccs
)
1574 (* does side effects on C ast and on Cocci info rule *)
1575 and process_a_ctl_a_env_a_toplevel2
r e c
f =
1576 indent_do
(fun () ->
1577 show_or_not_celem "trying" c
.ast_c
;
1578 Flag.currentfile
:= Some
(f ^
":" ^
get_celem c
.ast_c
);
1579 let (trans_info, returned_any_states
, inherited_bindings
, newbindings
) =
1580 Common.save_excursion
Flag_ctl.loop_in_src_code
(fun () ->
1581 Flag_ctl.loop_in_src_code
:= !Flag_ctl.loop_in_src_code
||c
.contain_loop;
1583 (***************************************)
1584 (* !Main point! The call to the engine *)
1585 (***************************************)
1586 let model_ctl = CCI.model_for_ctl
r.dropped_isos
(Common.some c
.flow) e
1587 in CCI.mysat
model_ctl r.ctl
(r.rule_info
.used_after
, e)
1590 if not returned_any_states
1593 show_or_not_celem "found match in" c
.ast_c
;
1594 show_or_not_trans_info trans_info;
1595 List.iter
(show_or_not_binding "out") newbindings
;
1597 r.rule_info
.was_matched
:= true;
1599 if not
(null
trans_info) &&
1600 not
(!Flag.sgrep_mode2
&& not
!Flag_cocci.show_diff
)
1602 c
.was_modified
:= true;
1604 (* les "more than one var in a decl" et "already tagged token"
1605 * font crasher coccinelle. Si on a 5 fichiers, donc on a 5
1606 * failed. Le try limite le scope des crashes pendant la
1607 * trasformation au fichier concerne. *)
1609 (* modify ast via side effect *)
1610 ignore
(Transformation_c.transform
r.rule_info
.rulename
r.dropped_isos
1611 inherited_bindings
trans_info (Common.some c
.flow));
1612 with Timeout
-> raise Timeout
| UnixExit i
-> raise
(UnixExit i
)
1615 Some
(List.map
(function x
-> x
@inherited_bindings
) newbindings
)
1619 and process_a_ctl_a_env_a_toplevel a b c
f=
1620 Common.profile_code
"process_a_ctl_a_env_a_toplevel"
1621 (fun () -> process_a_ctl_a_env_a_toplevel2 a b c
f)
1624 let rec bigloop2 rs
(ccs
: file_info list
) =
1625 let init_es = [(Ast_c.emptyMetavarsBinding
,[])] in
1626 let es = ref init_es in
1627 let ccs = ref ccs in
1628 let rules_that_have_ever_matched = ref [] in
1630 (* looping over the rules *)
1631 rs
+> List.iter
(fun r ->
1633 InitialScriptRuleCocciInfo
r | FinalScriptRuleCocciInfo
r -> ()
1634 | ScriptRuleCocciInfo
r ->
1635 if !Flag_cocci.show_ctl_text
then begin
1636 Common.pr_xxxxxxxxxxxxxxxxx
();
1637 pr
("script: " ^
r.language
);
1638 Common.pr_xxxxxxxxxxxxxxxxx
();
1640 adjust_pp_with_indent
(fun () ->
1641 Format.force_newline
();
1642 let (l,mv,script_vars
,code
) = r.scr_ast_rule
in
1643 let nm = r.scr_rule_info
.rulename
in
1644 let deps = r.scr_rule_info
.dependencies
in
1645 Pretty_print_cocci.unparse
1646 (Ast_cocci.ScriptRule
(nm,l,deps,mv,script_vars
,code
)));
1649 if !Flag.show_misc
then print_endline
"RESULT =";
1653 (function (cache
, newes
) ->
1654 function (e, rules_that_have_matched
) ->
1655 match r.language
with
1657 apply_script_rule r cache newes
e rules_that_have_matched
1658 rules_that_have_ever_matched python_application
1660 apply_script_rule r cache newes
e rules_that_have_matched
1661 rules_that_have_ever_matched ocaml_application
1663 concat_headers_and_c !ccs +> List.iter
(fun (c
,_) ->
1666 Printf.printf
"Flow: %s\r\nFlow!\r\n%!" c
.fullstring
);
1669 Printf.printf
"Unknown language: %s\n" r.language
;
1673 (if !(r.scr_rule_info
.was_matched
)
1675 Common.push2
r.scr_rule_info
.rulename
rules_that_have_ever_matched);
1677 es := newes
(*(if newes = [] then init_es else newes)*);
1678 | CocciRuleCocciInfo
r ->
1679 apply_cocci_rule r rules_that_have_ever_matched
1682 if !Flag.sgrep_mode2
1684 (* sgrep can lead to code that is not parsable, but we must
1685 * still call rebuild_info_c_and_headers to pretty print the
1686 * action (MINUS), so that later the diff will show what was
1687 * matched by sgrep. But we don't want the parsing error message
1688 * hence the following flag setting. So this code propably
1689 * will generate a NotParsedCorrectly for the matched parts
1690 * and the very final pretty print and diff will work
1692 Flag_parsing_c.verbose_parsing
:= false;
1693 ccs := rebuild_info_c_and_headers !ccs false
1695 !ccs (* return final C asts *)
1698 Common.profile_code
"bigloop" (fun () -> bigloop2 a b
)
1700 type init_final
= Initial
| Final
1702 let initial_final_bigloop2 ty rebuild
r =
1703 if !Flag_cocci.show_ctl_text
then
1705 Common.pr_xxxxxxxxxxxxxxxxx
();
1706 pr
((match ty
with Initial
-> "initial" | Final
-> "final") ^
": " ^
1708 Common.pr_xxxxxxxxxxxxxxxxx
();
1710 adjust_pp_with_indent
(fun () ->
1711 Format.force_newline
();
1712 Pretty_print_cocci.unparse
(rebuild
r.scr_ast_rule
r.scr_rule_info
.dependencies
));
1715 match r.language
with
1717 (* include_match makes no sense in an initial or final rule, although
1718 we have no way to prevent it *)
1719 let _ = apply_script_rule r [] [] [] [] (ref []) python_application in
1721 | "ocaml" when ty
= Initial
-> () (* nothing to do *)
1723 (* include_match makes no sense in an initial or final rule, although
1724 we have no way to prevent it *)
1725 let _ = apply_script_rule r [] [] [] [] (ref []) ocaml_application in
1728 failwith
("Unknown language for initial/final script: "^
1731 let initial_final_bigloop a b c
=
1732 Common.profile_code
"initial_final_bigloop"
1733 (fun () -> initial_final_bigloop2 a b c
)
1735 (*****************************************************************************)
1736 (* The main functions *)
1737 (*****************************************************************************)
1739 let pre_engine2 (coccifile
, isofile
) =
1740 show_or_not_cocci coccifile isofile
;
1741 Pycocci.set_coccifile coccifile
;
1744 if not
(Common.lfile_exists
isofile)
1746 pr2
("warning: Can't find default iso file: " ^
isofile);
1749 else Some
isofile in
1751 (* useful opti when use -dir *)
1752 let (metavars,astcocci
,
1753 free_var_lists
,negated_pos_lists
,used_after_lists
,
1754 positions_lists
,(toks
,_,_)) =
1755 sp_of_file coccifile
isofile in
1756 let ctls = ctls_of_ast astcocci used_after_lists positions_lists
in
1758 g_contain_typedmetavar := sp_contain_typed_metavar astcocci
;
1760 check_macro_in_sp_and_adjust toks
;
1762 show_or_not_ctl_tex astcocci
ctls;
1765 prepare_cocci ctls free_var_lists negated_pos_lists
1766 used_after_lists positions_lists
metavars astcocci
in
1768 let used_languages =
1770 (function languages
->
1772 ScriptRuleCocciInfo
(r) ->
1773 if List.mem
r.language languages
then
1776 r.language
::languages
1780 let initialized_languages =
1782 (function languages
->
1784 InitialScriptRuleCocciInfo
(r) ->
1785 (if List.mem
r.language languages
1788 ("double initializer found for "^
r.language
));
1789 if interpret_dependencies [] [] r.scr_rule_info
.dependencies
1792 initial_final_bigloop Initial
1793 (fun (x
,_,_,y
) -> fun deps ->
1794 Ast_cocci.InitialScriptRule
(r.scr_rule_info
.rulename
,x
,deps,y
))
1796 r.language
::languages
1802 let uninitialized_languages =
1804 (fun used
-> not
(List.mem used
initialized_languages))
1810 dependencies
= Ast_cocci.NoDep
;
1813 was_matched
= ref false;} in
1814 initial_final_bigloop Initial
1815 (fun (x
,_,_,y
) -> fun deps ->
1816 Ast_cocci.InitialScriptRule
("",x
,deps,y
))
1817 (make_init lgg
"" rule_info))
1818 uninitialized_languages;
1823 Common.profile_code
"pre_engine" (fun () -> pre_engine2 a
)
1825 let full_engine2 (cocci_infos,toks
) cfiles =
1827 show_or_not_cfiles cfiles;
1829 (* optimisation allowing to launch coccinelle on all the drivers *)
1830 if !Flag_cocci.worth_trying_opt
&& not
(worth_trying cfiles toks
)
1836 pr2
("No matches found for " ^
(Common.join
" " toks
)
1837 ^
"\nSkipping:" ^
(Common.join
" " cfiles)));
1838 cfiles +> List.map
(fun s -> s, None
)
1843 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1844 if !Flag.show_misc
then pr
"let's go";
1845 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1847 let choose_includes =
1848 match !Flag_cocci.include_options
with
1849 Flag_cocci.I_UNSPECIFIED
->
1850 if !g_contain_typedmetavar
1851 then Flag_cocci.I_NORMAL_INCLUDES
1852 else Flag_cocci.I_NO_INCLUDES
1854 let c_infos = prepare_c cfiles choose_includes in
1856 (* ! the big loop ! *)
1857 let c_infos'
= bigloop cocci_infos c_infos in
1859 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1860 if !Flag.show_misc
then pr
"Finished";
1861 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1862 if !Flag_ctl.graphical_trace
then gen_pdf_graph ();
1864 c_infos'
+> List.map
(fun c_or_h
->
1865 if !(c_or_h
.was_modified_once
)
1869 Common.new_temp_file
"cocci-output" ("-" ^ c_or_h
.fname
) in
1871 if c_or_h
.fkind
=*= Header
1872 then pr2
("a header file was modified: " ^ c_or_h
.fname
);
1874 (* and now unparse everything *)
1875 cfile_of_program (for_unparser c_or_h
.asts
) outfile;
1877 show_or_not_diff c_or_h
.fpath
outfile;
1880 if !Flag.sgrep_mode2
then None
else Some
outfile)
1882 else (c_or_h
.fpath
, None
))
1885 let full_engine a b
=
1886 Common.profile_code
"full_engine"
1887 (fun () -> let res = full_engine2 a b
in (*Gc.print_stat stderr; *)res)
1889 let post_engine2 (cocci_infos,_) =
1892 (function languages
->
1894 FinalScriptRuleCocciInfo
(r) ->
1895 (if List.mem
r.language languages
1896 then failwith
("double finalizer found for "^
r.language
));
1897 initial_final_bigloop Final
1898 (fun (x
,_,_,y
) -> fun deps ->
1899 Ast_cocci.FinalScriptRule
(r.scr_rule_info
.rulename
,x
,deps,y
))
1901 r.language
::languages
1907 Common.profile_code
"post_engine" (fun () -> post_engine2 a
)
1909 (*****************************************************************************)
1910 (* check duplicate from result of full_engine *)
1911 (*****************************************************************************)
1913 let check_duplicate_modif2 xs =
1914 (* opti: let groups = Common.groupBy (fun (a,resa) (b,resb) -> a =$= b) xs *)
1915 if !Flag_cocci.verbose_cocci
1916 then pr2
("Check duplication for " ^ i_to_s
(List.length
xs) ^
" files");
1918 let groups = Common.group_assoc_bykey_eff
xs in
1919 groups +> Common.map_filter
(fun (file, xs) ->
1921 | [] -> raise Impossible
1922 | [res] -> Some
(file, res)
1926 if not
(List.for_all
(fun res2
-> res2
=*= None
) xs)
1928 pr2
("different modification result for " ^
file);
1931 else Some
(file, None
)
1933 if not
(List.for_all
(fun res2
->
1937 let diff = Common.cmd_to_list
("diff -u -b -B "^
res^
" "^res2
)
1941 pr2
("different modification result for " ^
file);
1944 else Some
(file, Some
res)
1946 let check_duplicate_modif a
=
1947 Common.profile_code
"check_duplicate" (fun () -> check_duplicate_modif2 a
)