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 saved_typedefs saved_macros file
=
48 let (program2
, _stat
) =
49 Parse_c.parse_c_and_cpp_keep_typedefs
50 (Some saved_typedefs
) (Some saved_macros
) file
in
53 let cprogram_of_file_cached file
=
54 let ((program2
,typedefs
,macros
), _stat
) = Parse_c.parse_cache file
in
55 if !Flag_cocci.ifdef_to_if
58 program2
+> Parse_c.with_program2
(fun asts
->
59 Cpp_ast_c.cpp_ifdef_statementize asts
62 else (program2
,typedefs
,macros
)
64 let cfile_of_program program2_with_ppmethod outf
=
65 Unparse_c.pp_program program2_with_ppmethod outf
67 (* for memoization, contains only one entry, the one for the SP *)
68 let _hparse = Hashtbl.create
101
69 let _h_ocaml_init = Hashtbl.create
101
70 let _hctl = Hashtbl.create
101
72 (* --------------------------------------------------------------------- *)
74 (* --------------------------------------------------------------------- *)
75 (* for a given pair (file,iso), only keep an instance for the most recent
76 virtual rules and virtual_env *)
78 let sp_of_file2 file iso
=
81 let (_
,xs
,_
,_
,_
,_
,_
) as res
= Parse_cocci.process file iso
false in
82 (* if there is already a compiled ML code, do nothing and use that *)
83 try let _ = Hashtbl.find
_h_ocaml_init (file
,iso
) in res
86 Hashtbl.add
_h_ocaml_init (file
,iso
) ();
87 match Prepare_ocamlcocci.prepare file xs
with
89 | Some ocaml_script_file
->
91 Prepare_ocamlcocci.load_file ocaml_script_file
;
92 (if not
!Common.save_tmp_files
93 then Prepare_ocamlcocci.clean_file ocaml_script_file
);
96 Hashtbl.add
_hparse (file
,iso
)
97 (!Flag.defined_virtual_rules
,!Flag.defined_virtual_env
,new_code);
100 let (rules
,env
,code
) = Hashtbl.find
_hparse (file
,iso
) in
101 if rules
= !Flag.defined_virtual_rules
&& env
= !Flag.defined_virtual_env
103 else (Hashtbl.remove
_hparse (file
,iso
); redo())
104 with Not_found
-> redo()
106 let sp_of_file file iso
=
107 Common.profile_code
"parse cocci" (fun () -> sp_of_file2 file iso
)
110 (* --------------------------------------------------------------------- *)
112 (* --------------------------------------------------------------------- *)
113 let print_flow flow
=
114 Ograph_extended.print_ograph_mutable flow
"/tmp/test.dot" true
117 let ast_to_flow_with_error_messages2 x
=
119 try Ast_to_flow.ast_to_control_flow x
120 with Ast_to_flow.Error x
->
121 Ast_to_flow.report_error x
;
124 flowopt +> do_option
(fun flow
->
125 (* This time even if there is a deadcode, we still have a
126 * flow graph, so I can try the transformation and hope the
127 * deadcode will not bother us.
129 try Ast_to_flow.deadcode_detection flow
130 with Ast_to_flow.Error
(Ast_to_flow.DeadCode x
) ->
131 Ast_to_flow.report_error
(Ast_to_flow.DeadCode x
);
134 let ast_to_flow_with_error_messages a
=
135 Common.profile_code
"flow" (fun () -> ast_to_flow_with_error_messages2 a
)
138 (* --------------------------------------------------------------------- *)
140 (* --------------------------------------------------------------------- *)
142 let ctls_of_ast2 ast
(ua
,fua
,fuas
) pos
=
144 (function ast
-> function (ua
,(fua
,(fuas
,pos
))) ->
148 else Asttoctl2.asttoctl ast
(ua
,fua
,fuas
) pos
)
149 (Asttomember.asttomember ast ua
))
150 ast
(List.combine ua
(List.combine fua
(List.combine fuas pos
)))
152 let ctls_of_ast ast ua
=
153 Common.profile_code
"asttoctl2" (fun () -> ctls_of_ast2 ast ua
)
155 (*****************************************************************************)
156 (* Some debugging functions *)
157 (*****************************************************************************)
161 let show_or_not_cfile2 cfile
=
162 if !Flag_cocci.show_c
then begin
163 Common.pr2_xxxxxxxxxxxxxxxxx
();
164 pr2
("processing C file: " ^ cfile
);
165 Common.pr2_xxxxxxxxxxxxxxxxx
();
166 Common.command2
("cat " ^ cfile
);
168 let show_or_not_cfile a
=
169 Common.profile_code
"show_xxx" (fun () -> show_or_not_cfile2 a
)
171 let show_or_not_cfiles cfiles
= List.iter
show_or_not_cfile cfiles
174 let show_or_not_cocci2 coccifile isofile
=
175 if !Flag_cocci.show_cocci
then begin
176 Common.pr2_xxxxxxxxxxxxxxxxx
();
177 pr2
("processing semantic patch file: " ^ coccifile
);
178 isofile
+> (fun s
-> pr2
("with isos from: " ^ s
));
179 Common.pr2_xxxxxxxxxxxxxxxxx
();
180 Common.command2
("cat " ^ coccifile
);
183 let show_or_not_cocci a b
=
184 Common.profile_code
"show_xxx" (fun () -> show_or_not_cocci2 a b
)
186 (* ---------------------------------------------------------------------- *)
189 let fix_sgrep_diffs l
=
191 List.filter
(function s
-> (s
=~
"^\\+\\+\\+") || not
(s
=~
"^\\+")) l in
192 let l = List.rev
l in
193 (* adjust second number for + code *)
194 let rec loop1 n
= function
197 if s
=~
"^-" && not
(s
=~
"^---")
198 then s
:: loop1 (n
+1) ss
201 (match Str.split
(Str.regexp
" ") s
with
204 match Str.split
(Str.regexp
",") pl
with
207 | _ -> failwith
"bad + line information" in
208 let n2 = int_of_string
n2 in
209 (Printf.sprintf
"%s %s %s,%d %s" bef min n1
(n2-n
)
210 (String.concat
" " aft
))
212 | _ -> failwith
"bad @@ information")
213 else s
:: loop1 n ss
in
214 let rec loop2 n
= function
221 (match Str.split
(Str.regexp
" ") s
with
224 match (Str.split
(Str.regexp
",") min
,
225 Str.split
(Str.regexp
",") pl
) with
226 ([_;m2
],[n1
;n2]) -> (m2
,n1
,n2)
227 | ([_],[n1
;n2]) -> ("1",n1
,n2)
228 | ([_;m2
],[n1
]) -> (m2
,n1
,"1")
229 | ([_],[n1
]) -> ("1",n1
,"1")
230 | _ -> failwith
"bad -/+ line information" in
232 int_of_string
(String.sub
n1 1 ((String.length
n1)-1)) in
233 let m2 = int_of_string
m2 in
234 let n2 = int_of_string
n2 in
235 (Printf.sprintf
"%s %s +%d,%d %s" bef min
(n1-n
) n2
236 (String.concat
" " aft
))
237 :: loop2 (n
+(m2-n2)) ss
238 | _ -> failwith
"bad @@ information")
239 else s
:: loop2 n ss
in
240 loop2 0 (List.rev
(loop1 0 l))
242 let normalize_path file
=
244 if String.get file
0 = '
/'
then file
else (Sys.getcwd
()) ^
"/" ^ file
in
245 let elements = Str.split_delim
(Str.regexp
"/") fullpath in
246 let rec loop prev
= function
247 [] -> String.concat
"/" (List.rev prev
)
248 | "." :: rest
-> loop prev rest
251 x
::xs
-> loop xs rest
252 | _ -> failwith
"bad path")
253 | x
::rest
-> loop (x
::prev
) rest
in
256 let show_or_not_diff2 cfile outfile
=
257 if !Flag_cocci.show_diff
then begin
258 match Common.fst
(Compare_c.compare_to_original cfile outfile
) with
259 Compare_c.Correct
-> () (* diff only in spacing, etc *)
261 (* may need --strip-trailing-cr under windows *)
265 match !Flag_parsing_c.diff_lines
with
266 | None
-> "diff -u -p " ^ cfile ^
" " ^ outfile
267 | Some n
-> "diff -U "^n^
" -p "^cfile^
" "^outfile
in
269 let res = Common.cmd_to_list
line in
270 match (!Flag.patch
,res) with
271 (* create something that looks like the output of patch *)
272 (Some prefix
,minus_file
::plus_file
::rest
) ->
274 let lp = String.length
prefix in
275 if String.get
prefix (lp-1) = '
/'
276 then String.sub
prefix 0 (lp-1)
278 let drop_prefix file
=
279 let file = normalize_path file in
280 if Str.string_match
(Str.regexp
prefix) file 0
282 let lp = String.length
prefix in
283 let lf = String.length
file in
285 then String.sub
file lp (lf - lp)
288 (Printf.sprintf
"prefix %s doesn't match file %s"
292 (Printf.sprintf
"prefix %s doesn't match file %s"
295 match List.rev
(Str.split
(Str.regexp
" ") line) with
296 new_file
::old_file
::cmdrev
->
297 let old_base_file = drop_prefix old_file
in
302 (("/tmp/nothing"^
old_base_file)
303 :: old_file
:: cmdrev
))
307 (("b"^
old_base_file)::("a"^
old_base_file)::cmdrev
))
308 | _ -> failwith
"bad command" in
309 let (minus_line
,plus_line
) =
310 match (Str.split
(Str.regexp
"[ \t]") minus_file
,
311 Str.split
(Str.regexp
"[ \t]") plus_file
) with
312 ("---"::old_file
::old_rest
,"+++"::new_file
::new_rest
) ->
313 let old_base_file = drop_prefix old_file
in
315 then (minus_file
,"+++ /tmp/nothing"^
old_base_file)
318 ("---"::("a"^
old_base_file)::old_rest
),
320 ("+++"::("b"^
old_base_file)::new_rest
))
323 (Printf.sprintf
"bad diff header lines: %s %s"
324 (String.concat
":" l1
) (String.concat
":" l2
)) in
325 diff_line::minus_line
::plus_line
::rest
327 let xs = if !Flag.sgrep_mode2
then fix_sgrep_diffs xs else xs in
330 let show_or_not_diff a b
=
331 Common.profile_code
"show_xxx" (fun () -> show_or_not_diff2 a b
)
334 (* the derived input *)
336 let show_or_not_ctl_tex2 astcocci ctls
=
337 if !Flag_cocci.show_ctl_tex
then begin
338 Ctltotex.totex
("/tmp/__cocci_ctl.tex") astcocci ctls
;
339 Common.command2
("cd /tmp; latex __cocci_ctl.tex; " ^
340 "dvips __cocci_ctl.dvi -o __cocci_ctl.ps;" ^
341 "gv __cocci_ctl.ps &");
343 let show_or_not_ctl_tex a b
=
344 Common.profile_code
"show_xxx" (fun () -> show_or_not_ctl_tex2 a b
)
347 let show_or_not_rule_name ast rulenb
=
348 if !Flag_cocci.show_ctl_text
or !Flag.show_trying
or
349 !Flag.show_transinfo
or !Flag_cocci.show_binding_in_out
354 Ast_cocci.CocciRule
(nm
, (deps
, drops
, exists
), x
, _, _) -> nm
355 | _ -> i_to_s rulenb
in
356 Common.pr_xxxxxxxxxxxxxxxxx
();
358 Common.pr_xxxxxxxxxxxxxxxxx
()
361 let show_or_not_scr_rule_name rulenb
=
362 if !Flag_cocci.show_ctl_text
or !Flag.show_trying
or
363 !Flag.show_transinfo
or !Flag_cocci.show_binding_in_out
366 let name = i_to_s rulenb
in
367 Common.pr_xxxxxxxxxxxxxxxxx
();
368 pr
("script rule " ^
name ^
" = ");
369 Common.pr_xxxxxxxxxxxxxxxxx
()
372 let show_or_not_ctl_text2 ctl ast rulenb
=
373 if !Flag_cocci.show_ctl_text
then begin
375 adjust_pp_with_indent
(fun () ->
376 Format.force_newline
();
377 Pretty_print_cocci.print_plus_flag
:= true;
378 Pretty_print_cocci.print_minus_flag
:= true;
379 Pretty_print_cocci.unparse ast
;
384 adjust_pp_with_indent
(fun () ->
385 Format.force_newline
();
386 Pretty_print_engine.pp_ctlcocci
387 !Flag_cocci.show_mcodekind_in_ctl
!Flag_cocci.inline_let_ctl ctl
;
391 let show_or_not_ctl_text a b c
=
392 Common.profile_code
"show_xxx" (fun () -> show_or_not_ctl_text2 a b c
)
396 (* running information *)
397 let get_celem celem
: string =
399 Ast_c.Definition
({Ast_c.f_name
= namefuncs
;},_) ->
400 Ast_c.str_of_name namefuncs
402 (Ast_c.DeclList
([{Ast_c.v_namei
= Some
(name, _);}, _], _)) ->
403 Ast_c.str_of_name
name
406 let show_or_not_celem2 prelude celem
=
409 | Ast_c.Definition
({Ast_c.f_name
= namefuncs
},_) ->
410 let funcs = Ast_c.str_of_name namefuncs
in
411 Flag.current_element
:= funcs;
412 (" function: ",funcs)
414 (Ast_c.DeclList
([{Ast_c.v_namei
= Some
(name,_)}, _], _)) ->
415 let s = Ast_c.str_of_name
name in
416 Flag.current_element
:= s;
419 Flag.current_element
:= "something_else";
420 (" ","something else");
422 if !Flag.show_trying
then pr2
(prelude ^ tag ^ trying
)
424 let show_or_not_celem a b
=
425 Common.profile_code
"show_xxx" (fun () -> show_or_not_celem2 a b
)
428 let show_or_not_trans_info2 trans_info
=
429 (* drop witness tree indices for printing *)
431 List.map
(function (index
,trans_info) -> trans_info) trans_info in
432 if !Flag.show_transinfo
then begin
433 if null
trans_info then pr2
"transformation info is empty"
435 pr2
"transformation info returned:";
437 List.sort
(function (i1
,_,_) -> function (i2
,_,_) -> compare i1 i2
)
441 trans_info +> List.iter
(fun (i
, subst
, re
) ->
442 pr2
("transform state: " ^
(Common.i_to_s i
));
444 adjust_pp_with_indent_and_header
"with rule_elem: " (fun () ->
445 Pretty_print_cocci.print_plus_flag
:= true;
446 Pretty_print_cocci.print_minus_flag
:= true;
447 Pretty_print_cocci.rule_elem
"" re
;
449 adjust_pp_with_indent_and_header
"with binding: " (fun () ->
450 Pretty_print_engine.pp_binding subst
;
457 let show_or_not_trans_info a
=
458 Common.profile_code
"show_xxx" (fun () -> show_or_not_trans_info2 a
)
462 let show_or_not_binding2 s binding
=
463 if !Flag_cocci.show_binding_in_out
then begin
464 adjust_pp_with_indent_and_header
("binding " ^
s ^
" = ") (fun () ->
465 Pretty_print_engine.pp_binding binding
468 let show_or_not_binding a b
=
469 Common.profile_code
"show_xxx" (fun () -> show_or_not_binding2 a b
)
473 (*****************************************************************************)
474 (* Some helper functions *)
475 (*****************************************************************************)
477 let worth_trying cfiles tokens
=
478 (* drop the following line for a list of list by rules. since we don't
479 allow multiple minirules, all the tokens within a rule should be in
480 a single CFG entity *)
481 match (!Flag_cocci.windows
,tokens
) with
482 (true,_) | (_,None
) -> true
484 (* could also modify the code in get_constants.ml *)
485 let tokens = tokens +> List.map
(fun s ->
487 | _ when s =~
"^[A-Za-z_][A-Za-z_0-9]*$" ->
490 | _ when s =~
"^[A-Za-z_]" ->
493 | _ when s =~
".*[A-Za-z_]$" ->
498 let com = sprintf
"egrep -q '(%s)' %s" (join
"|" tokens) (join
" " cfiles
)
500 (match Sys.command
com with
501 | 0 (* success *) -> true
504 then Printf.printf
"grep failed: %s\n" com);
505 false (* no match, so not worth trying *))
507 let check_macro_in_sp_and_adjust = function
510 tokens +> List.iter
(fun s ->
511 if Hashtbl.mem
!Parse_c._defs
s
513 if !Flag_cocci.verbose_cocci
then begin
514 pr2
"warning: macro in semantic patch was in macro definitions";
515 pr2
("disabling macro expansion for " ^
s);
517 Hashtbl.remove
!Parse_c._defs
s
521 let contain_loop gopt
=
524 g#nodes#tolist
+> List.exists
(fun (xi
, node
) ->
525 Control_flow_c.extract_is_loop node
527 | None
-> true (* means nothing, if no g then will not model check *)
531 let sp_contain_typed_metavar_z toplevel_list_list
=
532 let bind x y
= x
or y
in
533 let option_default = false in
534 let mcode _ _ = option_default in
535 let donothing r k e
= k e
in
537 let expression r k e
=
538 match Ast_cocci.unwrap e
with
539 | Ast_cocci.MetaExpr
(_,_,_,Some t
,_,_) -> true
540 | Ast_cocci.MetaExpr
(_,_,_,_,Ast_cocci.LocalID
,_) -> true
545 Visitor_ast.combiner bind option_default
546 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
547 donothing donothing donothing donothing donothing
548 donothing expression donothing donothing donothing donothing donothing
549 donothing donothing donothing donothing donothing
551 toplevel_list_list
+>
553 (function (nm
,_,rule
) ->
554 (List.exists
combiner.Visitor_ast.combiner_top_level rule
))
556 let sp_contain_typed_metavar rules
=
557 sp_contain_typed_metavar_z
561 Ast_cocci.CocciRule
(a
,b
,c
,d
,_) -> (a
,b
,c
)
562 | _ -> failwith
"error in filter")
566 Ast_cocci.CocciRule
(a
,b
,c
,d
,Ast_cocci.Normal
) -> true
572 (* finding among the #include the one that we need to parse
573 * because they may contain useful type definition or because
574 * we may have to modify them
576 * For the moment we base in part our heuristic on the name of the file, e.g.
577 * serio.c is related we think to #include <linux/serio.h>
579 let include_table = Hashtbl.create
(100)
581 let interpret_include_path relpath
=
582 let maxdepth = List.length relpath
in
583 let unique_file_exists dir f
=
585 Printf.sprintf
"find %s -maxdepth %d -mindepth %d -path \"*/%s\""
586 dir
maxdepth maxdepth f
in
587 match Common.cmd_to_list
cmd with
590 let native_file_exists dir f
=
591 let f = Filename.concat dir
f in
595 let rec search_include_path exists searchlist relpath
=
596 match searchlist
with
599 (match exists hd relpath
with
601 | None
-> search_include_path exists tail relpath
) in
602 let rec search_path exists searchlist
= function
604 let res = Common.concat
"/" relpath
in
605 Hashtbl.add
include_table (searchlist
,relpath
) res;
607 | (hd
::tail
) as relpath1
->
608 let relpath1 = Common.concat
"/" relpath1 in
609 (match search_include_path exists searchlist
relpath1 with
610 None
-> search_path unique_file_exists searchlist tail
612 Hashtbl.add
include_table (searchlist
,relpath
) f;
615 match !Flag_cocci.include_path
with
618 try Some
(Hashtbl.find
include_table (searchlist,relpath
))
620 search_path native_file_exists searchlist relpath
622 let (includes_to_parse
:
623 (Common.filename
* Parse_c.extended_program2
) list
->
624 Flag_cocci.include_options
-> 'a
) = fun xs choose_includes
->
625 match choose_includes
with
626 Flag_cocci.I_UNSPECIFIED
-> failwith
"not possible"
627 | Flag_cocci.I_NO_INCLUDES
-> []
631 [Flag_cocci.I_ALL_INCLUDES
; Flag_cocci.I_REALLY_ALL_INCLUDES
] in
632 let xs = List.map
(function (file,(cs
,_,_)) -> (file,cs
)) xs in
633 xs +> List.map
(fun (file, cs
) ->
634 let dir = Common.dirname
file in
636 cs
+> Common.map_filter
(fun (c
,_info_item
) ->
640 {Ast_c.i_include
= ((x
,ii
)); i_rel_pos
= info_h_pos
;}) ->
643 let relpath = Common.join
"/" xs in
644 let f = Filename.concat
dir relpath in
645 if (Sys.file_exists
f) then
648 if !Flag_cocci.relax_include_path
649 (* for our tests, all the files are flat in the current dir *)
651 let attempt2 = Filename.concat
dir (Common.last
xs) in
652 if not
(Sys.file_exists
attempt2) && all_includes
654 interpret_include_path xs
657 if all_includes then interpret_include_path xs
660 | Ast_c.NonLocal
xs ->
662 Common.fileprefix
(Common.last
xs) =$
= Common.fileprefix
file
664 interpret_include_path xs
666 | Ast_c.Weird
_ -> None
670 +> (fun x
-> (List.rev
(Common.uniq
(List.rev x
)))) (*uniq keeps last*)
672 let rec interpret_dependencies local global
= function
673 Ast_cocci.Dep
s -> List.mem
s local
674 | Ast_cocci.AntiDep
s ->
675 (if !Flag_ctl.steps
!= None
676 then failwith
"steps and ! dependency incompatible");
677 not
(List.mem
s local
)
678 | Ast_cocci.EverDep
s -> List.mem
s global
679 | Ast_cocci.NeverDep
s ->
680 (if !Flag_ctl.steps
!= None
681 then failwith
"steps and ! dependency incompatible");
682 not
(List.mem
s global
)
683 | Ast_cocci.AndDep
(s1
,s2
) ->
684 (interpret_dependencies local global s1
) &&
685 (interpret_dependencies local global s2
)
686 | Ast_cocci.OrDep
(s1
,s2
) ->
687 (interpret_dependencies local global s1
) or
688 (interpret_dependencies local global s2
)
689 | Ast_cocci.NoDep
-> true
690 | Ast_cocci.FailDep
-> false
692 let rec print_dependencies str local global dep
=
693 if !Flag_cocci.show_dependencies
698 let rec loop = function
699 Ast_cocci.Dep
s | Ast_cocci.AntiDep
s ->
700 if not
(List.mem
s !seen)
704 then pr2
(s^
" satisfied")
705 else pr2
(s^
" not satisfied");
708 | Ast_cocci.EverDep
s | Ast_cocci.NeverDep
s ->
709 if not
(List.mem
s !seen)
713 then pr2
(s^
" satisfied")
714 else pr2
(s^
" not satisfied");
717 | Ast_cocci.AndDep
(s1
,s2
) ->
720 | Ast_cocci.OrDep
(s1
,s2
) ->
723 | Ast_cocci.NoDep
-> ()
724 | Ast_cocci.FailDep
-> pr2
"False not satisfied" in
728 (* --------------------------------------------------------------------- *)
729 (* #include relative position in the file *)
730 (* --------------------------------------------------------------------- *)
732 (* compute the set of new prefixes
734 * "a/b/x"; (* in fact it is now a list of string so ["a";"b";"x"] *)
738 * it would give
for the first element
739 * ""; "a"; "a/b"; "a/b/x"
743 * update
: if the
include is inside a ifdef a put nothing
. cf
-test incl
.
744 * this is because we dont want code added inside ifdef
.
747 let compute_new_prefixes xs =
748 xs +> Common.map_withenv
(fun already
xs ->
749 let subdirs_prefixes = Common.inits
xs in
750 let new_first = subdirs_prefixes +> List.filter
(fun x
->
751 not
(List.mem x already
)
760 (* does via side effect on the ref in the Include in Ast_c *)
761 let rec update_include_rel_pos cs
=
762 let only_include = cs
+> Common.map_filter
(fun c
->
764 | Ast_c.CppTop
(Ast_c.Include
{Ast_c.i_include
= ((x
,_));
766 i_is_in_ifdef
= inifdef
}) ->
768 | Ast_c.Weird
_ -> None
777 let (locals
, nonlocals
) =
778 only_include +> Common.partition_either
(fun (c
, aref
) ->
780 | Ast_c.Local x
-> Left
(x
, aref
)
781 | Ast_c.NonLocal x
-> Right
(x
, aref
)
782 | Ast_c.Weird x
-> raise Impossible
785 update_rel_pos_bis locals
;
786 update_rel_pos_bis nonlocals
;
788 and update_rel_pos_bis
xs =
789 let xs'
= List.map fst
xs in
790 let the_first = compute_new_prefixes xs'
in
791 let the_last = List.rev
(compute_new_prefixes (List.rev
xs'
)) in
792 let merged = Common.zip
xs (Common.zip
the_first the_last) in
793 merged +> List.iter
(fun ((x
, aref
), (the_first, the_last)) ->
796 Ast_c.first_of
= the_first;
797 Ast_c.last_of
= the_last;
802 (*****************************************************************************)
803 (* All the information needed around the C elements and Cocci rules *)
804 (*****************************************************************************)
806 type toplevel_c_info
= {
807 ast_c
: Ast_c.toplevel
; (* contain refs so can be modified *)
808 tokens_c
: Parser_c.token list
;
811 flow
: Control_flow_c.cflow
option; (* it's the "fixed" flow *)
814 env_typing_before
: TAC.environment
;
815 env_typing_after
: TAC.environment
;
817 was_modified
: bool ref;
819 all_typedefs
: (string, Lexer_parser.identkind
) Common.scoped_h_env
;
820 all_macros
: (string, Cpp_token_c.define_def
) Hashtbl.t
;
827 dependencies
: Ast_cocci.dependency
;
828 used_after
: Ast_cocci.meta_name list
;
830 was_matched
: bool ref;
833 type toplevel_cocci_info_script_rule
= {
836 (Ast_cocci.script_meta_name
* Ast_cocci.meta_name
*
837 Ast_cocci.metavar
) list
*
838 Ast_cocci.meta_name list
(*fresh vars*) *
842 scr_rule_info
: rule_info
;
845 type toplevel_cocci_info_cocci_rule
= {
846 ctl
: Lib_engine.ctlcocci
* (CCI.pred list list
);
847 metavars
: Ast_cocci.metavar list
;
848 ast_rule
: Ast_cocci.rule
;
849 isexp
: bool; (* true if + code is an exp, only for Flag.make_hrule *)
851 (* There are also some hardcoded rule names in parse_cocci.ml:
852 * let reserved_names = ["all";"optional_storage";"optional_qualifier"]
854 dropped_isos
: string list
;
855 free_vars
: Ast_cocci.meta_name list
;
856 negated_pos_vars
: Ast_cocci.meta_name list
;
857 positions
: Ast_cocci.meta_name list
;
859 ruletype
: Ast_cocci.ruletype
;
861 rule_info
: rule_info
;
864 type toplevel_cocci_info
=
865 ScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
866 | InitialScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
867 | FinalScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
868 | CocciRuleCocciInfo
of toplevel_cocci_info_cocci_rule
870 type cocci_info
= toplevel_cocci_info list
* string list
option (* tokens *)
872 type kind_file
= Header
| Source
876 was_modified_once
: bool ref;
877 asts
: toplevel_c_info list
;
882 let g_contain_typedmetavar = ref false
885 let last_env_toplevel_c_info xs =
886 (Common.last
xs).env_typing_after
888 let concat_headers_and_c (ccs
: file_info list
)
889 : (toplevel_c_info
* string) list
=
890 (List.concat
(ccs
+> List.map
(fun x
->
891 x
.asts
+> List.map
(fun x'
->
894 let for_unparser xs =
895 xs +> List.map
(fun x
->
896 (x
.ast_c
, (x
.fullstring
, x
.tokens_c
)), Unparse_c.PPviastr
899 let gen_pdf_graph () =
900 (Ctl_engine.get_graph_files
()) +> List.iter
(fun outfile
->
901 Printf.printf
"Generation of %s%!" outfile
;
902 let filename_stack = Ctl_engine.get_graph_comp_files outfile
in
903 List.iter
(fun filename
->
904 ignore
(Unix.system
("dot " ^ filename ^
" -Tpdf -o " ^ filename ^
".pdf;"))
906 let (head
,tail
) = (List.hd
filename_stack, List.tl
filename_stack) in
907 ignore
(Unix.system
("cp " ^ head ^
".pdf " ^ outfile ^
".pdf;"));
908 tail
+> List.iter
(fun filename
->
909 ignore
(Unix.system
("mv " ^ outfile ^
".pdf /tmp/tmp.pdf;"));
910 ignore
(Unix.system
("pdftk " ^ filename ^
".pdf /tmp/tmp.pdf cat output " ^ outfile ^
".pdf"));
912 ignore
(Unix.system
("rm /tmp/tmp.pdf;"));
913 List.iter
(fun filename
->
914 ignore
(Unix.system
("rm " ^ filename ^
" " ^ filename ^
".pdf;"))
916 Printf.printf
" - Done\n")
918 let local_python_code =
919 "from coccinelle import *\n"
922 "import coccinelle\n"^
924 "import coccilib.org\n"^
925 "import coccilib.report\n" ^
929 let make_init lang code rule_info
=
932 scr_ast_rule
= (lang
, mv, [], code
);
934 script_code
= (if lang
= "python" then python_code else "") ^code
;
935 scr_rule_info
= rule_info
;
938 (* --------------------------------------------------------------------- *)
939 let prepare_cocci ctls free_var_lists negated_pos_lists
940 (ua
,fua
,fuas
) positions_list metavars astcocci
=
942 let gathered = Common.index_list_1
943 (zip
(zip
(zip
(zip
(zip
(zip
(zip
(zip ctls metavars
) astcocci
)
945 negated_pos_lists
) ua
) fua
) fuas
) positions_list
)
948 (fun (((((((((ctl_toplevel_list
,metavars
),ast
),free_var_list
),
949 negated_pos_list
),ua
),fua
),fuas
),positions_list
),rulenb
) ->
951 let build_rule_info rulename deps
=
952 {rulename
= rulename
;
954 used_after
= (List.hd ua
) @ (List.hd fua
);
956 was_matched
= ref false;} in
958 let is_script_rule r
=
960 Ast_cocci.ScriptRule
_
961 | Ast_cocci.InitialScriptRule
_ | Ast_cocci.FinalScriptRule
_ -> true
964 if not
(List.length ctl_toplevel_list
=|= 1) && not
(is_script_rule ast
)
965 then failwith
"not handling multiple minirules";
968 Ast_cocci.ScriptRule
(name,lang
,deps
,mv,script_vars
,code
) ->
971 scr_ast_rule
= (lang
, mv, script_vars
, code
);
974 scr_rule_info
= build_rule_info name deps
;
976 in ScriptRuleCocciInfo
r
977 | Ast_cocci.InitialScriptRule
(name,lang
,deps
,code
) ->
978 let r = make_init lang code
(build_rule_info name deps
) in
979 InitialScriptRuleCocciInfo
r
980 | Ast_cocci.FinalScriptRule
(name,lang
,deps
,code
) ->
984 scr_ast_rule
= (lang
, mv, [], code
);
987 scr_rule_info
= build_rule_info name deps
;
989 in FinalScriptRuleCocciInfo
r
990 | Ast_cocci.CocciRule
991 (rulename
,(dependencies
,dropped_isos
,z
),restast
,isexp
,ruletype
) ->
994 ctl
= List.hd ctl_toplevel_list
;
997 isexp
= List.hd isexp
;
998 dropped_isos
= dropped_isos
;
999 free_vars
= List.hd free_var_list
;
1000 negated_pos_vars
= List.hd negated_pos_list
;
1001 positions
= List.hd positions_list
;
1002 ruletype
= ruletype
;
1003 rule_info
= build_rule_info rulename dependencies
;
1007 (* --------------------------------------------------------------------- *)
1009 let build_info_program (cprogram
,typedefs
,macros
) env
=
1011 let (cs
, parseinfos
) =
1012 Common.unzip cprogram
in
1015 parseinfos
+> List.map
(fun (s,toks
) -> toks
) +> List.flatten
in
1017 (* I use cs' but really annotate_xxx work by doing side effects on cs *)
1019 Comment_annotater_c.annotate_program
alltoks cs in
1021 Type_annoter_c.annotate_program env
(*!g_contain_typedmetavar*) cs'
1024 zip
cs_with_envs parseinfos
+> List.map
(fun ((c
, (enva
,envb
)), parseinfo
)->
1025 let (fullstr
, tokens) = parseinfo
in
1028 ast_to_flow_with_error_messages c
+>
1029 Common.map_option
(fun flow ->
1030 let flow = Ast_to_flow.annotate_loop_nodes
flow in
1032 (* remove the fake nodes for julia *)
1033 let fixed_flow = CCI.fix_flow_ctl
flow in
1035 if !Flag_cocci.show_flow
then print_flow fixed_flow;
1036 if !Flag_cocci.show_before_fixed_flow
then print_flow flow;
1043 ast_c
= c
; (* contain refs so can be modified *)
1045 fullstring
= fullstr
;
1049 contain_loop = contain_loop flow;
1051 env_typing_before
= enva
;
1052 env_typing_after
= envb
;
1054 was_modified
= ref false;
1056 all_typedefs
= typedefs
;
1057 all_macros
= macros
;
1063 (* Optimisation. Try not unparse/reparse the whole file when have modifs *)
1064 let rebuild_info_program cs file isexp
=
1065 cs +> List.map
(fun c
->
1066 if !(c
.was_modified
)
1068 let file = Common.new_temp_file
"cocci_small_output" ".c" in
1070 [(c
.ast_c
, (c
.fullstring
, c
.tokens_c
)), Unparse_c.PPnormal
]
1073 (* Common.command2 ("cat " ^ file); *)
1074 let cprogram = cprogram_of_file c
.all_typedefs c
.all_macros
file in
1075 let xs = build_info_program cprogram c
.env_typing_before
in
1077 (* TODO: assert env has not changed,
1078 * if yes then must also reparse what follows even if not modified.
1079 * Do that only if contain_typedmetavar of course, so good opti.
1081 (* Common.list_init xs *) (* get rid of the FinalDef *)
1087 let rebuild_info_c_and_headers ccs isexp
=
1088 ccs
+> List.iter
(fun c_or_h
->
1089 if c_or_h
.asts
+> List.exists
(fun c
-> !(c
.was_modified
))
1090 then c_or_h
.was_modified_once
:= true;
1092 ccs
+> List.map
(fun c_or_h
->
1095 rebuild_info_program c_or_h
.asts c_or_h
.full_fname isexp
}
1098 let rec prepare_h seen env hpath choose_includes
: file_info list
=
1099 if not
(Common.lfile_exists hpath
)
1102 pr2_once
("TYPE: header " ^ hpath ^
" not found");
1107 let h_cs = cprogram_of_file_cached hpath
in
1108 let local_includes =
1109 if choose_includes
=*= Flag_cocci.I_REALLY_ALL_INCLUDES
1112 (function x
-> not
(List.mem x
!seen))
1113 (includes_to_parse
[(hpath
,h_cs)] choose_includes
)
1115 seen := local_includes @ !seen;
1118 (List.map
(function x
-> prepare_h seen env x choose_includes
)
1120 let info_h_cs = build_info_program h_cs !env
in
1124 else last_env_toplevel_c_info info_h_cs;
1127 fname
= Common.basename hpath
;
1130 was_modified_once
= ref false;
1136 let prepare_c files choose_includes
: file_info list
=
1137 let cprograms = List.map
cprogram_of_file_cached files
in
1138 let includes = includes_to_parse
(zip files
cprograms) choose_includes
in
1139 let seen = ref includes in
1141 (* todo?: may not be good to first have all the headers and then all the c *)
1142 let env = ref !TAC.initial_env
in
1146 List.map
(function hpath
-> prepare_h seen env hpath choose_includes
) +>
1150 (zip files
cprograms) +>
1152 (function (file, cprogram) ->
1153 (* todo?: don't update env ? *)
1154 let cs = build_info_program cprogram !env in
1155 (* we do that only for the c, not for the h *)
1156 ignore
(update_include_rel_pos (cs +> List.map
(fun x
-> x
.ast_c
)));
1158 fname
= Common.basename
file;
1161 was_modified_once
= ref false;
1168 (*****************************************************************************)
1169 (* Processing the ctls and toplevel C elements *)
1170 (*****************************************************************************)
1172 (* The main algorithm =~
1173 * The algorithm is roughly:
1174 * for_all ctl rules in SP
1175 * for_all minirule in rule (no more)
1176 * for_all binding (computed during previous phase)
1177 * for_all C elements
1178 * match control flow of function vs minirule
1179 * with the binding and update the set of possible
1180 * bindings, and returned the possibly modified function.
1181 * pretty print modified C elements and reparse it.
1184 * On ne prends que les newbinding ou returned_any_state est vrai.
1185 * Si ca ne donne rien, on prends ce qu'il y avait au depart.
1186 * Mais au nouveau depart de quoi ?
1187 * - si ca donne rien apres avoir traité toutes les fonctions avec ce binding ?
1188 * - ou alors si ca donne rien, apres avoir traité toutes les fonctions
1189 * avec tous les bindings du round d'avant ?
1191 * Julia pense qu'il faut prendre la premiere solution.
1192 * Example: on a deux environnements candidats, E1 et E2 apres avoir traité
1193 * la regle ctl 1. On arrive sur la regle ctl 2.
1194 * E1 ne donne rien pour la regle 2, on garde quand meme E1 pour la regle 3.
1195 * E2 donne un match a un endroit et rend E2' alors on utilise ca pour
1198 * I have not to look at used_after_list to decide to restart from
1199 * scratch. I just need to look if the binding list is empty.
1200 * Indeed, let's suppose that a SP have 3 regions/rules. If we
1201 * don't find a match for the first region, then if this first
1202 * region does not bind metavariable used after, that is if
1203 * used_after_list is empty, then mysat(), even if does not find a
1204 * match, will return a Left, with an empty transformation_info,
1205 * and so current_binding will grow. On the contrary if the first
1206 * region must bind some metavariables used after, and that we
1207 * dont find any such region, then mysat() will returns lots of
1208 * Right, and current_binding will not grow, and so we will have
1209 * an empty list of binding, and we will catch such a case.
1211 * opti: julia says that because the binding is
1212 * determined by the used_after_list, the items in the list
1213 * are kind of sorted, so could optimise the insert_set operations.
1217 (* r(ule), c(element in C code), e(nvironment) *)
1220 let rec loop k
= function
1224 then Some
(x
, function n
-> k
(n
:: xs))
1225 else loop (function vs
-> k
(x
:: vs
)) xs in
1226 loop (function x
-> x
) l
1228 let merge_env new_e old_e
=
1231 (function (ext
,old_e
) ->
1232 function (e
,rules
) as elem
->
1233 match findk (function (e1
,_) -> e
=*= e1
) old_e
with
1234 None
-> (elem
:: ext
,old_e
)
1235 | Some
((_,old_rules
),k
) ->
1236 (ext
,k
(e
,Common.union_set rules old_rules
)))
1238 old_e
@ (List.rev ext
)
1240 let contains_binding e
(_,(r,m
),_) =
1242 let _ = List.find
(function ((re
, rm
), _) -> r =*= re
&& m
=$
= rm
) e
in
1244 with Not_found
-> false
1246 let python_application mv ve script_vars
r =
1250 ((Some x
,None
),y
,z
) -> (x
,y
,z
)
1253 (Printf.sprintf
"unexpected ast metavar in rule %s"
1254 r.scr_rule_info
.rulename
))
1257 Pycocci.build_classes
(List.map
(function (x
,y
) -> x
) ve
);
1258 Pycocci.construct_variables
mv ve
;
1259 Pycocci.construct_script_variables script_vars
;
1260 let _ = Pycocci.pyrun_simplestring
(local_python_code ^
r.script_code
) in
1261 if !Pycocci.inc_match
1262 then Some
(Pycocci.retrieve_script_variables script_vars
)
1264 with Pycocci.Pycocciexception
->
1265 (pr2
("Failure in " ^
r.scr_rule_info
.rulename
);
1266 raise
Pycocci.Pycocciexception
)
1268 let ocaml_application mv ve script_vars
r =
1271 Run_ocamlcocci.run
mv ve script_vars
1272 r.scr_rule_info
.rulename
r.script_code
in
1273 if !Coccilib.inc_match
1274 then Some
script_vals
1276 with e
-> (pr2
("Failure in " ^
r.scr_rule_info
.rulename
); raise e
)
1278 (* returns Left in case of dependency failure, Right otherwise *)
1279 let apply_script_rule r cache newes e rules_that_have_matched
1280 rules_that_have_ever_matched script_application
=
1281 Common.profile_code
r.language
(fun () ->
1282 show_or_not_scr_rule_name r.scr_rule_info
.ruleid
;
1283 if not
(interpret_dependencies rules_that_have_matched
1284 !rules_that_have_ever_matched
r.scr_rule_info
.dependencies
)
1287 print_dependencies "dependencies for script not satisfied:"
1288 rules_that_have_matched
1289 !rules_that_have_ever_matched
r.scr_rule_info
.dependencies
;
1290 show_or_not_binding "in environment" e
;
1291 (cache
, (e
, rules_that_have_matched
)::newes
)
1295 let (_, mv, script_vars
, _) = r.scr_ast_rule
in
1297 (List.map
(function (n
,v
) -> (("virtual",n
),Ast_c.MetaIdVal
(v
,[])))
1298 !Flag.defined_virtual_env
) @ e
in
1299 let not_bound x
= not
(contains_binding ve x
) in
1300 (match List.filter
not_bound mv with
1302 let relevant_bindings =
1304 (function ((re
,rm
),_) ->
1305 List.exists
(function (_,(r,m
),_) -> r =*= re
&& m
=$
= rm
) mv)
1308 match List.assoc
relevant_bindings cache
with
1309 None
-> (cache
,newes
)
1310 | Some
script_vals ->
1312 "dependencies for script satisfied, but cached:"
1313 rules_that_have_matched
1314 !rules_that_have_ever_matched
1315 r.scr_rule_info
.dependencies
;
1316 show_or_not_binding "in" e
;
1317 (* env might be bigger than what was cached against, so have to
1318 merge with newes anyway *)
1319 let new_e = (List.combine script_vars
script_vals) @ e
in
1323 (fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1324 (cache
,merge_env [(new_e, rules_that_have_matched
)] newes
)
1327 print_dependencies "dependencies for script satisfied:"
1328 rules_that_have_matched
1329 !rules_that_have_ever_matched
1330 r.scr_rule_info
.dependencies
;
1331 show_or_not_binding "in" e
;
1332 match script_application
mv ve script_vars
r with
1334 (* failure means we should drop e, no new bindings *)
1335 (((relevant_bindings,None
) :: cache
), newes
)
1336 | Some
script_vals ->
1338 List.map
(function x
-> Ast_c.MetaIdVal
(x
,[]))
1341 (List.combine script_vars
script_vals) @ e
in
1345 (fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1346 r.scr_rule_info
.was_matched
:= true;
1347 (((relevant_bindings,Some
script_vals) :: cache
),
1350 r.scr_rule_info
.rulename
:: rules_that_have_matched
)]
1354 (if !Flag_cocci.show_dependencies
1356 let m2c (_,(r,x
),_) = r^
"."^x
in
1357 pr2
(Printf.sprintf
"script not applied: %s not bound"
1358 (String.concat
", " (List.map
m2c unbound
))));
1362 (fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1363 (cache
, merge_env [(e, rules_that_have_matched
)] newes
))
1366 let rec apply_cocci_rule r rules_that_have_ever_matched es
1367 (ccs
:file_info list
ref) =
1368 Common.profile_code
r.rule_info
.rulename
(fun () ->
1369 show_or_not_rule_name r.ast_rule
r.rule_info
.ruleid
;
1370 show_or_not_ctl_text r.ctl
r.ast_rule
r.rule_info
.ruleid
;
1372 let reorganized_env =
1373 reassociate_positions
r.free_vars
r.negated_pos_vars
!es
in
1375 (* looping over the environments *)
1376 let (_,newes
(* envs for next round/rule *)) =
1378 (function (cache
,newes
) ->
1379 function ((e,rules_that_have_matched
),relevant_bindings) ->
1380 if not
(interpret_dependencies rules_that_have_matched
1381 !rules_that_have_ever_matched
1382 r.rule_info
.dependencies
)
1386 ("dependencies for rule "^
r.rule_info
.rulename^
1388 rules_that_have_matched
1389 !rules_that_have_ever_matched
r.rule_info
.dependencies
;
1390 show_or_not_binding "in environment" e;
1395 (fun (s,v
) -> List.mem
s r.rule_info
.used_after
),
1396 rules_that_have_matched
)]
1401 try List.assoc
relevant_bindings cache
1405 ("dependencies for rule "^
r.rule_info
.rulename^
1407 rules_that_have_matched
1408 !rules_that_have_ever_matched
1409 r.rule_info
.dependencies
;
1410 show_or_not_binding "in" e;
1411 show_or_not_binding "relevant in" relevant_bindings;
1413 (* applying the rule *)
1414 (match r.ruletype
with
1416 (* looping over the functions and toplevel elements in
1419 (concat_headers_and_c !ccs
+>
1420 List.fold_left
(fun children_e
(c
,f) ->
1423 (* does also some side effects on c and r *)
1425 process_a_ctl_a_env_a_toplevel
r
1426 relevant_bindings c
f in
1427 match processed with
1428 | None
-> children_e
1429 | Some newbindings
->
1432 (fun children_e newbinding
->
1433 if List.mem newbinding children_e
1435 else newbinding
:: children_e
)
1439 | Ast_cocci.Generated
->
1440 process_a_generated_a_env_a_toplevel
r
1441 relevant_bindings !ccs
;
1444 let old_bindings_to_keep =
1448 (fun (s,v
) -> List.mem
s r.rule_info
.used_after
)) in
1450 if null
new_bindings
1453 (*use the old bindings, specialized to the used_after_list*)
1454 if !Flag_ctl.partial_match
1457 "Empty list of bindings, I will restart from old env\n";
1458 [(old_bindings_to_keep,rules_that_have_matched
)]
1461 (* combine the new bindings with the old ones, and
1462 specialize to the used_after_list *)
1463 let old_variables = List.map fst
old_bindings_to_keep in
1464 (* have to explicitly discard the inherited variables
1465 because we want the inherited value of the positions
1466 variables not the extended one created by
1467 reassociate_positions. want to reassociate freshly
1468 according to the free variables of each rule. *)
1469 let new_bindings_to_add =
1475 (* see comment before combine_pos *)
1476 (s,Ast_c.MetaPosValList
[]) -> false
1478 List.mem
s r.rule_info
.used_after
&&
1479 not
(List.mem
s old_variables)))) in
1481 (function new_binding_to_add
->
1484 old_bindings_to_keep new_binding_to_add
),
1485 r.rule_info
.rulename
::rules_that_have_matched
))
1486 new_bindings_to_add in
1487 ((relevant_bindings,new_bindings)::cache
,
1488 merge_env new_e newes
))
1489 ([],[]) reorganized_env in (* end iter es *)
1490 if !(r.rule_info
.was_matched
)
1491 then Common.push2
r.rule_info
.rulename rules_that_have_ever_matched
;
1495 (* apply the tagged modifs and reparse *)
1496 if not
!Flag.sgrep_mode2
1497 then ccs
:= rebuild_info_c_and_headers !ccs
r.isexp
)
1499 and reassociate_positions free_vars negated_pos_vars envs
=
1500 (* issues: isolate the bindings that are relevant to a given rule.
1501 separate out the position variables
1502 associate all of the position variables for a given set of relevant
1503 normal variable bindings with each set of relevant normal variable
1504 bindings. Goal: if eg if@p (E) matches in two places, then both inherited
1505 occurrences of E should see both bindings of p, not just its own.
1506 Otherwise, a position constraint for something that matches in two
1507 places will never be useful, because the position can always be
1508 different from the other one. *)
1512 List.filter
(function (x
,_) -> List.mem x free_vars
) e)
1514 let splitted_relevant =
1515 (* separate the relevant variables into the non-position ones and the
1520 (function (non_pos
,pos
) ->
1521 function (v
,_) as x
->
1522 if List.mem v negated_pos_vars
1523 then (non_pos
,x
::pos
)
1524 else (x
::non_pos
,pos
))
1527 let splitted_relevant =
1529 (function (non_pos
,pos
) ->
1530 (List.sort compare non_pos
,List.sort compare pos
))
1531 splitted_relevant in
1534 (function non_pos
->
1536 if List.mem np non_pos
then non_pos
else np
::non_pos
)
1537 [] splitted_relevant in
1538 let extended_relevant =
1539 (* extend the position variables with the values found at other identical
1540 variable bindings *)
1542 (function non_pos
->
1545 (function (other_non_pos
,other_pos
) ->
1546 (* do we want equal? or just somehow compatible? eg non_pos
1547 binds only E, but other_non_pos binds both E and E1 *)
1548 non_pos
=*= other_non_pos
)
1549 splitted_relevant in
1553 (combine_pos negated_pos_vars
1554 (List.map
(function (_,x
) -> x
) others)))))
1557 (List.map
(function (non_pos
,_) -> List.assoc non_pos
extended_relevant)
1560 (* If the negated posvar is not bound at all, this function will
1561 nevertheless bind it to []. If we get rid of these bindings, then the
1562 matching of the term the position variable with the constraints will fail
1563 because some variables are unbound. So we let the binding be [] and then
1564 we will have to clean these up afterwards. This should be the only way
1565 that a position variable can have an empty binding. *)
1566 and combine_pos negated_pos_vars
others =
1572 (function positions ->
1573 function other_list
->
1575 match List.assoc posvar other_list
with
1576 Ast_c.MetaPosValList l1
->
1577 Common.union_set l1
positions
1578 | _ -> failwith
"bad value for a position variable"
1579 with Not_found
-> positions)
1581 (posvar
,Ast_c.MetaPosValList
positions))
1584 and process_a_generated_a_env_a_toplevel2
r env = function
1589 (rule
,_) when rule
=$
= r.rule_info
.rulename
-> false
1590 | (_,"ARGS") -> false
1593 let env_domain = List.map
(function (nm
,vl
) -> nm
) env in
1597 let (rl
,_) = Ast_cocci.get_meta_name md
in rl
=$
= r.rule_info
.rulename
)
1599 if Common.include_set
free_vars env_domain
1600 then Unparse_hrule.pp_rule
metavars r.ast_rule
env cfile
.full_fname
1601 | _ -> failwith
"multiple files not supported"
1603 and process_a_generated_a_env_a_toplevel rule
env ccs
=
1604 Common.profile_code
"process_a_ctl_a_env_a_toplevel"
1605 (fun () -> process_a_generated_a_env_a_toplevel2 rule
env ccs
)
1607 (* does side effects on C ast and on Cocci info rule *)
1608 and process_a_ctl_a_env_a_toplevel2
r e c
f =
1609 indent_do
(fun () ->
1610 show_or_not_celem "trying" c
.ast_c
;
1611 Flag.currentfile
:= Some
(f ^
":" ^
get_celem c
.ast_c
);
1612 let (trans_info, returned_any_states
, inherited_bindings
, newbindings
) =
1613 Common.save_excursion
Flag_ctl.loop_in_src_code
(fun () ->
1614 Flag_ctl.loop_in_src_code
:= !Flag_ctl.loop_in_src_code
||c
.contain_loop;
1616 (***************************************)
1617 (* !Main point! The call to the engine *)
1618 (***************************************)
1619 let model_ctl = CCI.model_for_ctl
r.dropped_isos
(Common.some c
.flow) e
1620 in CCI.mysat
model_ctl r.ctl
(r.rule_info
.used_after
, e)
1623 if not returned_any_states
1626 show_or_not_celem "found match in" c
.ast_c
;
1627 show_or_not_trans_info trans_info;
1628 List.iter
(show_or_not_binding "out") newbindings
;
1630 r.rule_info
.was_matched
:= true;
1632 if not
(null
trans_info) &&
1633 not
(!Flag.sgrep_mode2
&& not
!Flag_cocci.show_diff
)
1635 c
.was_modified
:= true;
1637 (* les "more than one var in a decl" et "already tagged token"
1638 * font crasher coccinelle. Si on a 5 fichiers, donc on a 5
1639 * failed. Le try limite le scope des crashes pendant la
1640 * trasformation au fichier concerne. *)
1642 (* modify ast via side effect *)
1643 ignore
(Transformation_c.transform
r.rule_info
.rulename
r.dropped_isos
1644 inherited_bindings
trans_info (Common.some c
.flow));
1645 with Timeout
-> raise Timeout
| UnixExit i
-> raise
(UnixExit i
)
1648 Some
(List.map
(function x
-> x
@inherited_bindings
) newbindings
)
1652 and process_a_ctl_a_env_a_toplevel a b c
f=
1653 Common.profile_code
"process_a_ctl_a_env_a_toplevel"
1654 (fun () -> process_a_ctl_a_env_a_toplevel2 a b c
f)
1657 let rec bigloop2 rs
(ccs
: file_info list
) =
1658 let init_es = [(Ast_c.emptyMetavarsBinding
,[])] in
1659 let es = ref init_es in
1660 let ccs = ref ccs in
1661 let rules_that_have_ever_matched = ref [] in
1663 (* looping over the rules *)
1664 rs
+> List.iter
(fun r ->
1666 InitialScriptRuleCocciInfo
r | FinalScriptRuleCocciInfo
r -> ()
1667 | ScriptRuleCocciInfo
r ->
1668 if !Flag_cocci.show_ctl_text
then begin
1669 Common.pr_xxxxxxxxxxxxxxxxx
();
1670 pr
("script: " ^
r.language
);
1671 Common.pr_xxxxxxxxxxxxxxxxx
();
1673 adjust_pp_with_indent
(fun () ->
1674 Format.force_newline
();
1675 let (l,mv,script_vars
,code
) = r.scr_ast_rule
in
1676 let nm = r.scr_rule_info
.rulename
in
1677 let deps = r.scr_rule_info
.dependencies
in
1678 Pretty_print_cocci.unparse
1679 (Ast_cocci.ScriptRule
(nm,l,deps,mv,script_vars
,code
)));
1682 if !Flag.show_misc
then print_endline
"RESULT =";
1686 (function (cache
, newes
) ->
1687 function (e, rules_that_have_matched
) ->
1688 match r.language
with
1690 apply_script_rule r cache newes
e rules_that_have_matched
1691 rules_that_have_ever_matched python_application
1693 apply_script_rule r cache newes
e rules_that_have_matched
1694 rules_that_have_ever_matched ocaml_application
1696 concat_headers_and_c !ccs +> List.iter
(fun (c
,_) ->
1699 Printf.printf
"Flow: %s\r\nFlow!\r\n%!" c
.fullstring
);
1702 Printf.printf
"Unknown language: %s\n" r.language
;
1706 (if !(r.scr_rule_info
.was_matched
)
1708 Common.push2
r.scr_rule_info
.rulename
rules_that_have_ever_matched);
1710 es := newes
(*(if newes = [] then init_es else newes)*);
1711 | CocciRuleCocciInfo
r ->
1712 apply_cocci_rule r rules_that_have_ever_matched
1715 if !Flag.sgrep_mode2
1717 (* sgrep can lead to code that is not parsable, but we must
1718 * still call rebuild_info_c_and_headers to pretty print the
1719 * action (MINUS), so that later the diff will show what was
1720 * matched by sgrep. But we don't want the parsing error message
1721 * hence the following flag setting. So this code propably
1722 * will generate a NotParsedCorrectly for the matched parts
1723 * and the very final pretty print and diff will work
1725 Flag_parsing_c.verbose_parsing
:= false;
1726 ccs := rebuild_info_c_and_headers !ccs false
1728 !ccs (* return final C asts *)
1731 Common.profile_code
"bigloop" (fun () -> bigloop2 a b
)
1733 type init_final
= Initial
| Final
1735 let initial_final_bigloop2 ty rebuild
r =
1736 if !Flag_cocci.show_ctl_text
then
1738 Common.pr_xxxxxxxxxxxxxxxxx
();
1739 pr
((match ty
with Initial
-> "initial" | Final
-> "final") ^
": " ^
1741 Common.pr_xxxxxxxxxxxxxxxxx
();
1743 adjust_pp_with_indent
(fun () ->
1744 Format.force_newline
();
1745 Pretty_print_cocci.unparse
(rebuild
r.scr_ast_rule
r.scr_rule_info
.dependencies
));
1748 match r.language
with
1750 (* include_match makes no sense in an initial or final rule, although
1751 we have no way to prevent it *)
1752 let _ = apply_script_rule r [] [] [] [] (ref []) python_application in
1754 | "ocaml" when ty
= Initial
-> () (* nothing to do *)
1756 (* include_match makes no sense in an initial or final rule, although
1757 we have no way to prevent it *)
1758 let _ = apply_script_rule r [] [] [] [] (ref []) ocaml_application in
1761 failwith
("Unknown language for initial/final script: "^
1764 let initial_final_bigloop a b c
=
1765 Common.profile_code
"initial_final_bigloop"
1766 (fun () -> initial_final_bigloop2 a b c
)
1768 (*****************************************************************************)
1769 (* The main functions *)
1770 (*****************************************************************************)
1772 let pre_engine2 (coccifile
, isofile
) =
1773 show_or_not_cocci coccifile isofile
;
1774 Pycocci.set_coccifile coccifile
;
1777 if not
(Common.lfile_exists
isofile)
1779 pr2
("warning: Can't find default iso file: " ^
isofile);
1782 else Some
isofile in
1784 (* useful opti when use -dir *)
1785 let (metavars,astcocci
,
1786 free_var_lists
,negated_pos_lists
,used_after_lists
,
1787 positions_lists
,(toks
,_,_)) =
1788 sp_of_file coccifile
isofile in
1789 let ctls = ctls_of_ast astcocci used_after_lists positions_lists
in
1791 g_contain_typedmetavar := sp_contain_typed_metavar astcocci
;
1793 check_macro_in_sp_and_adjust toks
;
1795 show_or_not_ctl_tex astcocci
ctls;
1798 prepare_cocci ctls free_var_lists negated_pos_lists
1799 used_after_lists positions_lists
metavars astcocci
in
1801 let used_languages =
1803 (function languages
->
1805 ScriptRuleCocciInfo
(r) ->
1806 if List.mem
r.language languages
then
1809 r.language
::languages
1814 let rlang = r.language
in
1815 let rname = r.scr_rule_info
.rulename
in
1817 let _ = List.assoc
(rlang,rname) !Iteration.initialization_stack
in
1821 Iteration.initialization_stack
:=
1822 ((rlang,rname),!Flag.defined_virtual_rules
) ::
1823 !Iteration.initialization_stack
;
1824 initial_final_bigloop Initial
1825 (fun (x
,_,_,y
) -> fun deps ->
1826 Ast_cocci.InitialScriptRule
(rname,x
,deps,y
))
1830 let initialized_languages =
1832 (function languages
->
1834 InitialScriptRuleCocciInfo
(r) ->
1835 let rlang = r.language
in
1836 (if List.mem
rlang languages
1837 then failwith
("double initializer found for "^
rlang));
1838 if interpret_dependencies [] [] r.scr_rule_info
.dependencies
1839 then begin runrule r; rlang::languages
end
1844 let uninitialized_languages =
1846 (fun used
-> not
(List.mem used
initialized_languages))
1853 dependencies
= Ast_cocci.NoDep
;
1856 was_matched
= ref false;} in
1857 runrule (make_init lgg
"" rule_info))
1858 uninitialized_languages;
1863 Common.profile_code
"pre_engine" (fun () -> pre_engine2 a
)
1865 let full_engine2 (cocci_infos,toks
) cfiles =
1867 show_or_not_cfiles cfiles;
1869 (* optimisation allowing to launch coccinelle on all the drivers *)
1870 if !Flag_cocci.worth_trying_opt
&& not
(worth_trying cfiles toks
)
1876 pr2
("No matches found for " ^
(Common.join
" " toks
)
1877 ^
"\nSkipping:" ^
(Common.join
" " cfiles)));
1878 cfiles +> List.map
(fun s -> s, None
)
1883 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1884 if !Flag.show_misc
then pr
"let's go";
1885 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1887 let choose_includes =
1888 match !Flag_cocci.include_options
with
1889 Flag_cocci.I_UNSPECIFIED
->
1890 if !g_contain_typedmetavar
1891 then Flag_cocci.I_NORMAL_INCLUDES
1892 else Flag_cocci.I_NO_INCLUDES
1894 let c_infos = prepare_c cfiles choose_includes in
1896 (* ! the big loop ! *)
1897 let c_infos'
= bigloop cocci_infos c_infos in
1899 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1900 if !Flag.show_misc
then pr
"Finished";
1901 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1902 if !Flag_ctl.graphical_trace
then gen_pdf_graph ();
1904 c_infos'
+> List.map
(fun c_or_h
->
1905 if !(c_or_h
.was_modified_once
)
1909 Common.new_temp_file
"cocci-output" ("-" ^ c_or_h
.fname
) in
1911 if c_or_h
.fkind
=*= Header
1912 then pr2
("a header file was modified: " ^ c_or_h
.fname
);
1914 (* and now unparse everything *)
1915 cfile_of_program (for_unparser c_or_h
.asts
) outfile;
1917 show_or_not_diff c_or_h
.fpath
outfile;
1920 if !Flag.sgrep_mode2
then None
else Some
outfile)
1922 else (c_or_h
.fpath
, None
))
1925 let full_engine a b
=
1926 Common.profile_code
"full_engine"
1927 (fun () -> let res = full_engine2 a b
in (*Gc.print_stat stderr; *)res)
1929 let post_engine2 (cocci_infos,_) =
1931 (function ((language
,_),virt_rules
) ->
1932 Flag.defined_virtual_rules
:= virt_rules
;
1935 (function languages
->
1937 FinalScriptRuleCocciInfo
(r) ->
1938 (if r.language
= language
&& List.mem
r.language languages
1939 then failwith
("double finalizer found for "^
r.language
));
1940 initial_final_bigloop Final
1941 (fun (x
,_,_,y
) -> fun deps ->
1942 Ast_cocci.FinalScriptRule
(r.scr_rule_info
.rulename
,
1945 r.language
::languages
1949 !Iteration.initialization_stack
1952 Common.profile_code
"post_engine" (fun () -> post_engine2 a
)
1954 (*****************************************************************************)
1955 (* check duplicate from result of full_engine *)
1956 (*****************************************************************************)
1958 let check_duplicate_modif2 xs =
1959 (* opti: let groups = Common.groupBy (fun (a,resa) (b,resb) -> a =$= b) xs *)
1960 if !Flag_cocci.verbose_cocci
1961 then pr2
("Check duplication for " ^ i_to_s
(List.length
xs) ^
" files");
1963 let groups = Common.group_assoc_bykey_eff
xs in
1964 groups +> Common.map_filter
(fun (file, xs) ->
1966 | [] -> raise Impossible
1967 | [res] -> Some
(file, res)
1971 if not
(List.for_all
(fun res2
-> res2
=*= None
) xs)
1973 pr2
("different modification result for " ^
file);
1976 else Some
(file, None
)
1978 if not
(List.for_all
(fun res2
->
1982 let diff = Common.cmd_to_list
("diff -u -b -B "^
res^
" "^res2
)
1986 pr2
("different modification result for " ^
file);
1989 else Some
(file, Some
res)
1991 let check_duplicate_modif a
=
1992 Common.profile_code
"check_duplicate" (fun () -> check_duplicate_modif2 a
)