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
341 (function ((Asttoctl2.NONDECL ctl
| Asttoctl2.CODE ctl
),x
) ->
344 Ctltotex.totex
("/tmp/__cocci_ctl.tex") astcocci
ctls;
345 Common.command2
("cd /tmp; latex __cocci_ctl.tex; " ^
346 "dvips __cocci_ctl.dvi -o __cocci_ctl.ps;" ^
347 "gv __cocci_ctl.ps &");
349 let show_or_not_ctl_tex a b
=
350 Common.profile_code
"show_xxx" (fun () -> show_or_not_ctl_tex2 a b
)
353 let show_or_not_rule_name ast rulenb
=
354 if !Flag_cocci.show_ctl_text
or !Flag.show_trying
or
355 !Flag.show_transinfo
or !Flag_cocci.show_binding_in_out
360 Ast_cocci.CocciRule
(nm
, (deps
, drops
, exists
), x
, _, _) -> nm
361 | _ -> i_to_s rulenb
in
362 Common.pr_xxxxxxxxxxxxxxxxx
();
364 Common.pr_xxxxxxxxxxxxxxxxx
()
367 let show_or_not_scr_rule_name rulenb
=
368 if !Flag_cocci.show_ctl_text
or !Flag.show_trying
or
369 !Flag.show_transinfo
or !Flag_cocci.show_binding_in_out
372 let name = i_to_s rulenb
in
373 Common.pr_xxxxxxxxxxxxxxxxx
();
374 pr
("script rule " ^
name ^
" = ");
375 Common.pr_xxxxxxxxxxxxxxxxx
()
378 let show_or_not_ctl_text2 ctl ast rulenb
=
379 if !Flag_cocci.show_ctl_text
then begin
381 adjust_pp_with_indent
(fun () ->
382 Format.force_newline
();
383 Pretty_print_cocci.print_plus_flag
:= true;
384 Pretty_print_cocci.print_minus_flag
:= true;
385 Pretty_print_cocci.unparse ast
;
389 let ((Asttoctl2.CODE ctl
| Asttoctl2.NONDECL ctl
),_) = ctl
in
390 adjust_pp_with_indent
(fun () ->
391 Format.force_newline
();
392 Pretty_print_engine.pp_ctlcocci
393 !Flag_cocci.show_mcodekind_in_ctl
!Flag_cocci.inline_let_ctl ctl
;
397 let show_or_not_ctl_text a b c
=
398 Common.profile_code
"show_xxx" (fun () -> show_or_not_ctl_text2 a b c
)
402 (* running information *)
403 let get_celem celem
: string =
405 Ast_c.Definition
({Ast_c.f_name
= namefuncs
;},_) ->
406 Ast_c.str_of_name namefuncs
408 (Ast_c.DeclList
([{Ast_c.v_namei
= Some
(name, _);}, _], _)) ->
409 Ast_c.str_of_name
name
412 let show_or_not_celem2 prelude celem
=
415 | Ast_c.Definition
({Ast_c.f_name
= namefuncs
},_) ->
416 let funcs = Ast_c.str_of_name namefuncs
in
417 Flag.current_element
:= funcs;
418 (" function: ",funcs)
420 (Ast_c.DeclList
([{Ast_c.v_namei
= Some
(name,_)}, _], _)) ->
421 let s = Ast_c.str_of_name
name in
422 Flag.current_element
:= s;
425 Flag.current_element
:= "something_else";
426 (" ","something else");
428 if !Flag.show_trying
then pr2
(prelude ^ tag ^ trying
)
430 let show_or_not_celem a b
=
431 Common.profile_code
"show_xxx" (fun () -> show_or_not_celem2 a b
)
434 let show_or_not_trans_info2 trans_info
=
435 (* drop witness tree indices for printing *)
437 List.map
(function (index
,trans_info) -> trans_info) trans_info in
438 if !Flag.show_transinfo
then begin
439 if null
trans_info then pr2
"transformation info is empty"
441 pr2
"transformation info returned:";
443 List.sort
(function (i1
,_,_) -> function (i2
,_,_) -> compare i1 i2
)
447 trans_info +> List.iter
(fun (i
, subst
, re
) ->
448 pr2
("transform state: " ^
(Common.i_to_s i
));
450 adjust_pp_with_indent_and_header
"with rule_elem: " (fun () ->
451 Pretty_print_cocci.print_plus_flag
:= true;
452 Pretty_print_cocci.print_minus_flag
:= true;
453 Pretty_print_cocci.rule_elem
"" re
;
455 adjust_pp_with_indent_and_header
"with binding: " (fun () ->
456 Pretty_print_engine.pp_binding subst
;
463 let show_or_not_trans_info a
=
464 Common.profile_code
"show_xxx" (fun () -> show_or_not_trans_info2 a
)
468 let show_or_not_binding2 s binding
=
469 if !Flag_cocci.show_binding_in_out
then begin
470 adjust_pp_with_indent_and_header
("binding " ^
s ^
" = ") (fun () ->
471 Pretty_print_engine.pp_binding binding
474 let show_or_not_binding a b
=
475 Common.profile_code
"show_xxx" (fun () -> show_or_not_binding2 a b
)
479 (*****************************************************************************)
480 (* Some helper functions *)
481 (*****************************************************************************)
483 let worth_trying cfiles tokens
=
484 (* drop the following line for a list of list by rules. since we don't
485 allow multiple minirules, all the tokens within a rule should be in
486 a single CFG entity *)
487 match (!Flag_cocci.windows
,tokens
) with
488 (true,_) | (_,None
) -> true
490 (* could also modify the code in get_constants.ml *)
491 let tokens = tokens +> List.map
(fun s ->
493 | _ when s =~
"^[A-Za-z_][A-Za-z_0-9]*$" ->
496 | _ when s =~
"^[A-Za-z_]" ->
499 | _ when s =~
".*[A-Za-z_]$" ->
504 let com = sprintf
"egrep -q '(%s)' %s" (join
"|" tokens) (join
" " cfiles
)
506 (match Sys.command
com with
507 | 0 (* success *) -> true
510 then Printf.printf
"grep failed: %s\n" com);
511 false (* no match, so not worth trying *))
513 let check_macro_in_sp_and_adjust = function
516 tokens +> List.iter
(fun s ->
517 if Hashtbl.mem
!Parse_c._defs
s
519 if !Flag_cocci.verbose_cocci
then begin
520 pr2
"warning: macro in semantic patch was in macro definitions";
521 pr2
("disabling macro expansion for " ^
s);
523 Hashtbl.remove
!Parse_c._defs
s
527 let contain_loop gopt
=
530 g#nodes#tolist
+> List.exists
(fun (xi
, node
) ->
531 Control_flow_c.extract_is_loop node
533 | None
-> true (* means nothing, if no g then will not model check *)
537 let sp_contain_typed_metavar_z toplevel_list_list
=
538 let bind x y
= x
or y
in
539 let option_default = false in
540 let mcode _ _ = option_default in
541 let donothing r k e
= k e
in
543 let expression r k e
=
544 match Ast_cocci.unwrap e
with
545 | Ast_cocci.MetaExpr
(_,_,_,Some t
,_,_) -> true
546 | Ast_cocci.MetaExpr
(_,_,_,_,Ast_cocci.LocalID
,_) -> true
551 Visitor_ast.combiner bind option_default
552 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
553 donothing donothing donothing donothing donothing
554 donothing expression donothing donothing donothing donothing donothing
555 donothing donothing donothing donothing donothing
557 toplevel_list_list
+>
559 (function (nm
,_,rule
) ->
560 (List.exists
combiner.Visitor_ast.combiner_top_level rule
))
562 let sp_contain_typed_metavar rules
=
563 sp_contain_typed_metavar_z
567 Ast_cocci.CocciRule
(a
,b
,c
,d
,_) -> (a
,b
,c
)
568 | _ -> failwith
"error in filter")
572 Ast_cocci.CocciRule
(a
,b
,c
,d
,Ast_cocci.Normal
) -> true
578 (* finding among the #include the one that we need to parse
579 * because they may contain useful type definition or because
580 * we may have to modify them
582 * For the moment we base in part our heuristic on the name of the file, e.g.
583 * serio.c is related we think to #include <linux/serio.h>
585 let include_table = Hashtbl.create
(100)
587 let interpret_include_path relpath
=
588 let maxdepth = List.length relpath
in
589 let unique_file_exists dir f
=
591 Printf.sprintf
"find %s -maxdepth %d -mindepth %d -path \"*/%s\""
592 dir
maxdepth maxdepth f
in
593 match Common.cmd_to_list
cmd with
596 let native_file_exists dir f
=
597 let f = Filename.concat dir
f in
601 let rec search_include_path exists searchlist relpath
=
602 match searchlist
with
605 (match exists hd relpath
with
607 | None
-> search_include_path exists tail relpath
) in
608 let rec search_path exists searchlist
= function
610 let res = Common.concat
"/" relpath
in
611 Hashtbl.add
include_table (searchlist
,relpath
) res;
613 | (hd
::tail
) as relpath1
->
614 let relpath1 = Common.concat
"/" relpath1 in
615 (match search_include_path exists searchlist
relpath1 with
616 None
-> search_path unique_file_exists searchlist tail
618 Hashtbl.add
include_table (searchlist
,relpath
) f;
621 match !Flag_cocci.include_path
with
624 try Some
(Hashtbl.find
include_table (searchlist,relpath
))
626 search_path native_file_exists searchlist relpath
628 let (includes_to_parse
:
629 (Common.filename
* Parse_c.extended_program2
) list
->
630 Flag_cocci.include_options
-> 'a
) = fun xs choose_includes
->
631 match choose_includes
with
632 Flag_cocci.I_UNSPECIFIED
-> failwith
"not possible"
633 | Flag_cocci.I_NO_INCLUDES
-> []
637 [Flag_cocci.I_ALL_INCLUDES
; Flag_cocci.I_REALLY_ALL_INCLUDES
] in
638 let xs = List.map
(function (file,(cs
,_,_)) -> (file,cs
)) xs in
639 xs +> List.map
(fun (file, cs
) ->
640 let dir = Common.dirname
file in
642 cs
+> Common.map_filter
(fun (c
,_info_item
) ->
646 {Ast_c.i_include
= ((x
,ii
)); i_rel_pos
= info_h_pos
;}) ->
649 let relpath = Common.join
"/" xs in
650 let f = Filename.concat
dir relpath in
651 if (Sys.file_exists
f) then
654 if !Flag_cocci.relax_include_path
655 (* for our tests, all the files are flat in the current dir *)
657 let attempt2 = Filename.concat
dir (Common.last
xs) in
658 if not
(Sys.file_exists
attempt2) && all_includes
660 interpret_include_path xs
663 if all_includes then interpret_include_path xs
666 | Ast_c.NonLocal
xs ->
668 Common.fileprefix
(Common.last
xs) =$
= Common.fileprefix
file
670 interpret_include_path xs
672 | Ast_c.Weird
_ -> None
676 +> (fun x
-> (List.rev
(Common.uniq
(List.rev x
)))) (*uniq keeps last*)
678 let rec interpret_dependencies local global
= function
679 Ast_cocci.Dep
s -> List.mem
s local
680 | Ast_cocci.AntiDep
s ->
681 (if !Flag_ctl.steps
!= None
682 then failwith
"steps and ! dependency incompatible");
683 not
(List.mem
s local
)
684 | Ast_cocci.EverDep
s -> List.mem
s global
685 | Ast_cocci.NeverDep
s ->
686 (if !Flag_ctl.steps
!= None
687 then failwith
"steps and ! dependency incompatible");
688 not
(List.mem
s global
)
689 | Ast_cocci.AndDep
(s1
,s2
) ->
690 (interpret_dependencies local global s1
) &&
691 (interpret_dependencies local global s2
)
692 | Ast_cocci.OrDep
(s1
,s2
) ->
693 (interpret_dependencies local global s1
) or
694 (interpret_dependencies local global s2
)
695 | Ast_cocci.NoDep
-> true
696 | Ast_cocci.FailDep
-> false
698 let rec print_dependencies str local global dep
=
699 if !Flag_cocci.show_dependencies
704 let rec loop = function
705 Ast_cocci.Dep
s | Ast_cocci.AntiDep
s ->
706 if not
(List.mem
s !seen)
710 then pr2
(s^
" satisfied")
711 else pr2
(s^
" not satisfied");
714 | Ast_cocci.EverDep
s | Ast_cocci.NeverDep
s ->
715 if not
(List.mem
s !seen)
719 then pr2
(s^
" satisfied")
720 else pr2
(s^
" not satisfied");
723 | Ast_cocci.AndDep
(s1
,s2
) ->
726 | Ast_cocci.OrDep
(s1
,s2
) ->
729 | Ast_cocci.NoDep
-> ()
730 | Ast_cocci.FailDep
-> pr2
"False not satisfied" in
734 (* --------------------------------------------------------------------- *)
735 (* #include relative position in the file *)
736 (* --------------------------------------------------------------------- *)
738 (* compute the set of new prefixes
740 * "a/b/x"; (* in fact it is now a list of string so ["a";"b";"x"] *)
744 * it would give
for the first element
745 * ""; "a"; "a/b"; "a/b/x"
749 * update
: if the
include is inside a ifdef a put nothing
. cf
-test incl
.
750 * this is because we dont want code added inside ifdef
.
753 let compute_new_prefixes xs =
754 xs +> Common.map_withenv
(fun already
xs ->
755 let subdirs_prefixes = Common.inits
xs in
756 let new_first = subdirs_prefixes +> List.filter
(fun x
->
757 not
(List.mem x already
)
766 (* does via side effect on the ref in the Include in Ast_c *)
767 let rec update_include_rel_pos cs
=
768 let only_include = cs
+> Common.map_filter
(fun c
->
770 | Ast_c.CppTop
(Ast_c.Include
{Ast_c.i_include
= ((x
,_));
772 i_is_in_ifdef
= inifdef
}) ->
774 | Ast_c.Weird
_ -> None
783 let (locals
, nonlocals
) =
784 only_include +> Common.partition_either
(fun (c
, aref
) ->
786 | Ast_c.Local x
-> Left
(x
, aref
)
787 | Ast_c.NonLocal x
-> Right
(x
, aref
)
788 | Ast_c.Weird x
-> raise Impossible
791 update_rel_pos_bis locals
;
792 update_rel_pos_bis nonlocals
;
794 and update_rel_pos_bis
xs =
795 let xs'
= List.map fst
xs in
796 let the_first = compute_new_prefixes xs'
in
797 let the_last = List.rev
(compute_new_prefixes (List.rev
xs'
)) in
798 let merged = Common.zip
xs (Common.zip
the_first the_last) in
799 merged +> List.iter
(fun ((x
, aref
), (the_first, the_last)) ->
802 Ast_c.first_of
= the_first;
803 Ast_c.last_of
= the_last;
808 (*****************************************************************************)
809 (* All the information needed around the C elements and Cocci rules *)
810 (*****************************************************************************)
812 type toplevel_c_info
= {
813 ast_c
: Ast_c.toplevel
; (* contain refs so can be modified *)
814 tokens_c
: Parser_c.token list
;
817 flow
: Control_flow_c.cflow
option; (* it's the "fixed" flow *)
820 env_typing_before
: TAC.environment
;
821 env_typing_after
: TAC.environment
;
823 was_modified
: bool ref;
825 all_typedefs
: (string, Lexer_parser.identkind
) Common.scoped_h_env
;
826 all_macros
: (string, Cpp_token_c.define_def
) Hashtbl.t
;
833 dependencies
: Ast_cocci.dependency
;
834 used_after
: Ast_cocci.meta_name list
;
836 was_matched
: bool ref;
839 type toplevel_cocci_info_script_rule
= {
842 (Ast_cocci.script_meta_name
* Ast_cocci.meta_name
*
843 Ast_cocci.metavar
) list
*
844 Ast_cocci.meta_name list
(*fresh vars*) *
848 scr_rule_info
: rule_info
;
851 type toplevel_cocci_info_cocci_rule
= {
852 ctl
: Asttoctl2.top_formula
* (CCI.pred list list
);
853 metavars
: Ast_cocci.metavar list
;
854 ast_rule
: Ast_cocci.rule
;
855 isexp
: bool; (* true if + code is an exp, only for Flag.make_hrule *)
857 (* There are also some hardcoded rule names in parse_cocci.ml:
858 * let reserved_names = ["all";"optional_storage";"optional_qualifier"]
860 dropped_isos
: string list
;
861 free_vars
: Ast_cocci.meta_name list
;
862 negated_pos_vars
: Ast_cocci.meta_name list
;
863 positions
: Ast_cocci.meta_name list
;
865 ruletype
: Ast_cocci.ruletype
;
867 rule_info
: rule_info
;
870 type toplevel_cocci_info
=
871 ScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
872 | InitialScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
873 | FinalScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
874 | CocciRuleCocciInfo
of toplevel_cocci_info_cocci_rule
876 type cocci_info
= toplevel_cocci_info list
* string list
option (* tokens *)
878 type kind_file
= Header
| Source
882 was_modified_once
: bool ref;
883 asts
: toplevel_c_info list
;
888 let g_contain_typedmetavar = ref false
891 let last_env_toplevel_c_info xs =
892 (Common.last
xs).env_typing_after
894 let concat_headers_and_c (ccs
: file_info list
)
895 : (toplevel_c_info
* string) list
=
896 (List.concat
(ccs
+> List.map
(fun x
->
897 x
.asts
+> List.map
(fun x'
->
900 let for_unparser xs =
901 xs +> List.map
(fun x
->
902 (x
.ast_c
, (x
.fullstring
, x
.tokens_c
)), Unparse_c.PPviastr
905 let gen_pdf_graph () =
906 (Ctl_engine.get_graph_files
()) +> List.iter
(fun outfile
->
907 Printf.printf
"Generation of %s%!" outfile
;
908 let filename_stack = Ctl_engine.get_graph_comp_files outfile
in
909 List.iter
(fun filename
->
910 ignore
(Unix.system
("dot " ^ filename ^
" -Tpdf -o " ^ filename ^
".pdf;"))
912 let (head
,tail
) = (List.hd
filename_stack, List.tl
filename_stack) in
913 ignore
(Unix.system
("cp " ^ head ^
".pdf " ^ outfile ^
".pdf;"));
914 tail
+> List.iter
(fun filename
->
915 ignore
(Unix.system
("mv " ^ outfile ^
".pdf /tmp/tmp.pdf;"));
916 ignore
(Unix.system
("pdftk " ^ filename ^
".pdf /tmp/tmp.pdf cat output " ^ outfile ^
".pdf"));
918 ignore
(Unix.system
("rm /tmp/tmp.pdf;"));
919 List.iter
(fun filename
->
920 ignore
(Unix.system
("rm " ^ filename ^
" " ^ filename ^
".pdf;"))
922 Printf.printf
" - Done\n")
924 let local_python_code =
925 "from coccinelle import *\n"
928 "import coccinelle\n"^
930 "import coccilib.org\n"^
931 "import coccilib.report\n" ^
935 let make_init lang code rule_info
=
938 scr_ast_rule
= (lang
, mv, [], code
);
940 script_code
= (if lang
= "python" then python_code else "") ^code
;
941 scr_rule_info
= rule_info
;
944 (* --------------------------------------------------------------------- *)
945 let prepare_cocci ctls free_var_lists negated_pos_lists
946 (ua
,fua
,fuas
) positions_list metavars astcocci
=
948 let gathered = Common.index_list_1
949 (zip
(zip
(zip
(zip
(zip
(zip
(zip
(zip
ctls metavars
) astcocci
)
951 negated_pos_lists
) ua
) fua
) fuas
) positions_list
)
954 (fun (((((((((ctl_toplevel_list
,metavars
),ast
),free_var_list
),
955 negated_pos_list
),ua
),fua
),fuas
),positions_list
),rulenb
) ->
957 let build_rule_info rulename deps
=
958 {rulename
= rulename
;
960 used_after
= (List.hd ua
) @ (List.hd fua
);
962 was_matched
= ref false;} in
964 let is_script_rule r
=
966 Ast_cocci.ScriptRule
_
967 | Ast_cocci.InitialScriptRule
_ | Ast_cocci.FinalScriptRule
_ -> true
970 if not
(List.length ctl_toplevel_list
=|= 1) && not
(is_script_rule ast
)
971 then failwith
"not handling multiple minirules";
974 Ast_cocci.ScriptRule
(name,lang
,deps
,mv,script_vars
,code
) ->
977 scr_ast_rule
= (lang
, mv, script_vars
, code
);
980 scr_rule_info
= build_rule_info name deps
;
982 in ScriptRuleCocciInfo
r
983 | Ast_cocci.InitialScriptRule
(name,lang
,deps
,code
) ->
984 let r = make_init lang code
(build_rule_info name deps
) in
985 InitialScriptRuleCocciInfo
r
986 | Ast_cocci.FinalScriptRule
(name,lang
,deps
,code
) ->
990 scr_ast_rule
= (lang
, mv, [], code
);
993 scr_rule_info
= build_rule_info name deps
;
995 in FinalScriptRuleCocciInfo
r
996 | Ast_cocci.CocciRule
997 (rulename
,(dependencies
,dropped_isos
,z
),restast
,isexp
,ruletype
) ->
1000 ctl
= List.hd ctl_toplevel_list
;
1001 metavars
= metavars
;
1003 isexp
= List.hd isexp
;
1004 dropped_isos
= dropped_isos
;
1005 free_vars
= List.hd free_var_list
;
1006 negated_pos_vars
= List.hd negated_pos_list
;
1007 positions
= List.hd positions_list
;
1008 ruletype
= ruletype
;
1009 rule_info
= build_rule_info rulename dependencies
;
1013 (* --------------------------------------------------------------------- *)
1015 let build_info_program (cprogram
,typedefs
,macros
) env
=
1017 let (cs
, parseinfos
) =
1018 Common.unzip cprogram
in
1021 parseinfos
+> List.map
(fun (s,toks
) -> toks
) +> List.flatten
in
1023 (* I use cs' but really annotate_xxx work by doing side effects on cs *)
1025 Comment_annotater_c.annotate_program
alltoks cs in
1027 Type_annoter_c.annotate_program env
(*!g_contain_typedmetavar*) cs'
1030 zip
cs_with_envs parseinfos
+> List.map
(fun ((c
, (enva
,envb
)), parseinfo
)->
1031 let (fullstr
, tokens) = parseinfo
in
1034 ast_to_flow_with_error_messages c
+>
1035 Common.map_option
(fun flow ->
1036 let flow = Ast_to_flow.annotate_loop_nodes
flow in
1038 (* remove the fake nodes for julia *)
1039 let fixed_flow = CCI.fix_flow_ctl
flow in
1041 if !Flag_cocci.show_flow
then print_flow fixed_flow;
1042 if !Flag_cocci.show_before_fixed_flow
then print_flow flow;
1049 ast_c
= c
; (* contain refs so can be modified *)
1051 fullstring
= fullstr
;
1055 contain_loop = contain_loop flow;
1057 env_typing_before
= enva
;
1058 env_typing_after
= envb
;
1060 was_modified
= ref false;
1062 all_typedefs
= typedefs
;
1063 all_macros
= macros
;
1069 (* Optimisation. Try not unparse/reparse the whole file when have modifs *)
1070 let rebuild_info_program cs file isexp
=
1071 cs +> List.map
(fun c
->
1072 if !(c
.was_modified
)
1074 let file = Common.new_temp_file
"cocci_small_output" ".c" in
1076 [(c
.ast_c
, (c
.fullstring
, c
.tokens_c
)), Unparse_c.PPnormal
]
1079 (* Common.command2 ("cat " ^ file); *)
1080 let cprogram = cprogram_of_file c
.all_typedefs c
.all_macros
file in
1081 let xs = build_info_program cprogram c
.env_typing_before
in
1083 (* TODO: assert env has not changed,
1084 * if yes then must also reparse what follows even if not modified.
1085 * Do that only if contain_typedmetavar of course, so good opti.
1087 (* Common.list_init xs *) (* get rid of the FinalDef *)
1093 let rebuild_info_c_and_headers ccs isexp
=
1094 ccs
+> List.iter
(fun c_or_h
->
1095 if c_or_h
.asts
+> List.exists
(fun c
-> !(c
.was_modified
))
1096 then c_or_h
.was_modified_once
:= true;
1098 ccs
+> List.map
(fun c_or_h
->
1101 rebuild_info_program c_or_h
.asts c_or_h
.full_fname isexp
}
1104 let rec prepare_h seen env hpath choose_includes
: file_info list
=
1105 if not
(Common.lfile_exists hpath
)
1108 pr2_once
("TYPE: header " ^ hpath ^
" not found");
1113 let h_cs = cprogram_of_file_cached hpath
in
1114 let local_includes =
1115 if choose_includes
=*= Flag_cocci.I_REALLY_ALL_INCLUDES
1118 (function x
-> not
(List.mem x
!seen))
1119 (includes_to_parse
[(hpath
,h_cs)] choose_includes
)
1121 seen := local_includes @ !seen;
1124 (List.map
(function x
-> prepare_h seen env x choose_includes
)
1126 let info_h_cs = build_info_program h_cs !env
in
1130 else last_env_toplevel_c_info info_h_cs;
1133 fname
= Common.basename hpath
;
1136 was_modified_once
= ref false;
1142 let prepare_c files choose_includes
: file_info list
=
1143 let cprograms = List.map
cprogram_of_file_cached files
in
1144 let includes = includes_to_parse
(zip files
cprograms) choose_includes
in
1145 let seen = ref includes in
1147 (* todo?: may not be good to first have all the headers and then all the c *)
1148 let env = ref !TAC.initial_env
in
1152 List.map
(function hpath
-> prepare_h seen env hpath choose_includes
) +>
1156 (zip files
cprograms) +>
1158 (function (file, cprogram) ->
1159 (* todo?: don't update env ? *)
1160 let cs = build_info_program cprogram !env in
1161 (* we do that only for the c, not for the h *)
1162 ignore
(update_include_rel_pos (cs +> List.map
(fun x
-> x
.ast_c
)));
1164 fname
= Common.basename
file;
1167 was_modified_once
= ref false;
1174 (*****************************************************************************)
1175 (* Processing the ctls and toplevel C elements *)
1176 (*****************************************************************************)
1178 (* The main algorithm =~
1179 * The algorithm is roughly:
1180 * for_all ctl rules in SP
1181 * for_all minirule in rule (no more)
1182 * for_all binding (computed during previous phase)
1183 * for_all C elements
1184 * match control flow of function vs minirule
1185 * with the binding and update the set of possible
1186 * bindings, and returned the possibly modified function.
1187 * pretty print modified C elements and reparse it.
1190 * On ne prends que les newbinding ou returned_any_state est vrai.
1191 * Si ca ne donne rien, on prends ce qu'il y avait au depart.
1192 * Mais au nouveau depart de quoi ?
1193 * - si ca donne rien apres avoir traité toutes les fonctions avec ce binding ?
1194 * - ou alors si ca donne rien, apres avoir traité toutes les fonctions
1195 * avec tous les bindings du round d'avant ?
1197 * Julia pense qu'il faut prendre la premiere solution.
1198 * Example: on a deux environnements candidats, E1 et E2 apres avoir traité
1199 * la regle ctl 1. On arrive sur la regle ctl 2.
1200 * E1 ne donne rien pour la regle 2, on garde quand meme E1 pour la regle 3.
1201 * E2 donne un match a un endroit et rend E2' alors on utilise ca pour
1204 * I have not to look at used_after_list to decide to restart from
1205 * scratch. I just need to look if the binding list is empty.
1206 * Indeed, let's suppose that a SP have 3 regions/rules. If we
1207 * don't find a match for the first region, then if this first
1208 * region does not bind metavariable used after, that is if
1209 * used_after_list is empty, then mysat(), even if does not find a
1210 * match, will return a Left, with an empty transformation_info,
1211 * and so current_binding will grow. On the contrary if the first
1212 * region must bind some metavariables used after, and that we
1213 * dont find any such region, then mysat() will returns lots of
1214 * Right, and current_binding will not grow, and so we will have
1215 * an empty list of binding, and we will catch such a case.
1217 * opti: julia says that because the binding is
1218 * determined by the used_after_list, the items in the list
1219 * are kind of sorted, so could optimise the insert_set operations.
1223 (* r(ule), c(element in C code), e(nvironment) *)
1226 let rec loop k
= function
1230 then Some
(x
, function n
-> k
(n
:: xs))
1231 else loop (function vs
-> k
(x
:: vs
)) xs in
1232 loop (function x
-> x
) l
1234 let merge_env new_e old_e
=
1237 (function (ext
,old_e
) ->
1238 function (e
,rules
) as elem
->
1239 match findk (function (e1
,_) -> e
=*= e1
) old_e
with
1240 None
-> (elem
:: ext
,old_e
)
1241 | Some
((_,old_rules
),k
) ->
1242 (ext
,k
(e
,Common.union_set rules old_rules
)))
1244 old_e
@ (List.rev ext
)
1246 let contains_binding e
(_,(r,m
),_) =
1248 let _ = List.find
(function ((re
, rm
), _) -> r =*= re
&& m
=$
= rm
) e
in
1250 with Not_found
-> false
1252 let python_application mv ve script_vars
r =
1256 ((Some x
,None
),y
,z
) -> (x
,y
,z
)
1259 (Printf.sprintf
"unexpected ast metavar in rule %s"
1260 r.scr_rule_info
.rulename
))
1263 Pycocci.build_classes
(List.map
(function (x
,y
) -> x
) ve
);
1264 Pycocci.construct_variables
mv ve
;
1265 Pycocci.construct_script_variables script_vars
;
1266 let _ = Pycocci.pyrun_simplestring
(local_python_code ^
r.script_code
) in
1267 if !Pycocci.inc_match
1268 then Some
(Pycocci.retrieve_script_variables script_vars
)
1270 with Pycocci.Pycocciexception
->
1271 (pr2
("Failure in " ^
r.scr_rule_info
.rulename
);
1272 raise
Pycocci.Pycocciexception
)
1274 let ocaml_application mv ve script_vars
r =
1277 Run_ocamlcocci.run
mv ve script_vars
1278 r.scr_rule_info
.rulename
r.script_code
in
1279 if !Coccilib.inc_match
1280 then Some
script_vals
1282 with e
-> (pr2
("Failure in " ^
r.scr_rule_info
.rulename
); raise e
)
1284 (* returns Left in case of dependency failure, Right otherwise *)
1285 let apply_script_rule r cache newes e rules_that_have_matched
1286 rules_that_have_ever_matched script_application
=
1287 Common.profile_code
r.language
(fun () ->
1288 show_or_not_scr_rule_name r.scr_rule_info
.ruleid
;
1289 if not
(interpret_dependencies rules_that_have_matched
1290 !rules_that_have_ever_matched
r.scr_rule_info
.dependencies
)
1293 print_dependencies "dependencies for script not satisfied:"
1294 rules_that_have_matched
1295 !rules_that_have_ever_matched
r.scr_rule_info
.dependencies
;
1296 show_or_not_binding "in environment" e
;
1297 (cache
, (e
, rules_that_have_matched
)::newes
)
1301 let (_, mv, script_vars
, _) = r.scr_ast_rule
in
1303 (List.map
(function (n
,v
) -> (("virtual",n
),Ast_c.MetaIdVal
(v
,[])))
1304 !Flag.defined_virtual_env
) @ e
in
1305 let not_bound x
= not
(contains_binding ve x
) in
1306 (match List.filter
not_bound mv with
1308 let relevant_bindings =
1310 (function ((re
,rm
),_) ->
1311 List.exists
(function (_,(r,m
),_) -> r =*= re
&& m
=$
= rm
) mv)
1314 match List.assoc
relevant_bindings cache
with
1315 None
-> (cache
,newes
)
1316 | Some
script_vals ->
1318 "dependencies for script satisfied, but cached:"
1319 rules_that_have_matched
1320 !rules_that_have_ever_matched
1321 r.scr_rule_info
.dependencies
;
1322 show_or_not_binding "in" e
;
1323 (* env might be bigger than what was cached against, so have to
1324 merge with newes anyway *)
1325 let new_e = (List.combine script_vars
script_vals) @ e
in
1329 (fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1330 (cache
,merge_env [(new_e, rules_that_have_matched
)] newes
)
1333 print_dependencies "dependencies for script satisfied:"
1334 rules_that_have_matched
1335 !rules_that_have_ever_matched
1336 r.scr_rule_info
.dependencies
;
1337 show_or_not_binding "in" e
;
1338 match script_application
mv ve script_vars
r with
1340 (* failure means we should drop e, no new bindings *)
1341 (((relevant_bindings,None
) :: cache
), newes
)
1342 | Some
script_vals ->
1344 List.map
(function x
-> Ast_c.MetaIdVal
(x
,[]))
1347 (List.combine script_vars
script_vals) @ e
in
1351 (fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1352 r.scr_rule_info
.was_matched
:= true;
1353 (((relevant_bindings,Some
script_vals) :: cache
),
1356 r.scr_rule_info
.rulename
:: rules_that_have_matched
)]
1360 (if !Flag_cocci.show_dependencies
1362 let m2c (_,(r,x
),_) = r^
"."^x
in
1363 pr2
(Printf.sprintf
"script not applied: %s not bound"
1364 (String.concat
", " (List.map
m2c unbound
))));
1368 (fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1369 (cache
, merge_env [(e, rules_that_have_matched
)] newes
))
1372 let rec apply_cocci_rule r rules_that_have_ever_matched es
1373 (ccs
:file_info list
ref) =
1374 Common.profile_code
r.rule_info
.rulename
(fun () ->
1375 show_or_not_rule_name r.ast_rule
r.rule_info
.ruleid
;
1376 show_or_not_ctl_text r.ctl
r.ast_rule
r.rule_info
.ruleid
;
1378 let reorganized_env =
1379 reassociate_positions
r.free_vars
r.negated_pos_vars
!es
in
1381 (* looping over the environments *)
1382 let (_,newes
(* envs for next round/rule *)) =
1384 (function (cache
,newes
) ->
1385 function ((e,rules_that_have_matched
),relevant_bindings) ->
1386 if not
(interpret_dependencies rules_that_have_matched
1387 !rules_that_have_ever_matched
1388 r.rule_info
.dependencies
)
1392 ("dependencies for rule "^
r.rule_info
.rulename^
1394 rules_that_have_matched
1395 !rules_that_have_ever_matched
r.rule_info
.dependencies
;
1396 show_or_not_binding "in environment" e;
1401 (fun (s,v
) -> List.mem
s r.rule_info
.used_after
),
1402 rules_that_have_matched
)]
1407 try List.assoc
relevant_bindings cache
1411 ("dependencies for rule "^
r.rule_info
.rulename^
1413 rules_that_have_matched
1414 !rules_that_have_ever_matched
1415 r.rule_info
.dependencies
;
1416 show_or_not_binding "in" e;
1417 show_or_not_binding "relevant in" relevant_bindings;
1419 (* applying the rule *)
1420 (match r.ruletype
with
1422 (* looping over the functions and toplevel elements in
1425 (concat_headers_and_c !ccs
+>
1426 List.fold_left
(fun children_e
(c
,f) ->
1429 (* does also some side effects on c and r *)
1431 process_a_ctl_a_env_a_toplevel
r
1432 relevant_bindings c
f in
1433 match processed with
1434 | None
-> children_e
1435 | Some newbindings
->
1438 (fun children_e newbinding
->
1439 if List.mem newbinding children_e
1441 else newbinding
:: children_e
)
1445 | Ast_cocci.Generated
->
1446 process_a_generated_a_env_a_toplevel
r
1447 relevant_bindings !ccs
;
1450 let old_bindings_to_keep =
1454 (fun (s,v
) -> List.mem
s r.rule_info
.used_after
)) in
1456 if null
new_bindings
1459 (*use the old bindings, specialized to the used_after_list*)
1460 if !Flag_ctl.partial_match
1463 "Empty list of bindings, I will restart from old env\n";
1464 [(old_bindings_to_keep,rules_that_have_matched
)]
1467 (* combine the new bindings with the old ones, and
1468 specialize to the used_after_list *)
1469 let old_variables = List.map fst
old_bindings_to_keep in
1470 (* have to explicitly discard the inherited variables
1471 because we want the inherited value of the positions
1472 variables not the extended one created by
1473 reassociate_positions. want to reassociate freshly
1474 according to the free variables of each rule. *)
1475 let new_bindings_to_add =
1481 (* see comment before combine_pos *)
1482 (s,Ast_c.MetaPosValList
[]) -> false
1484 List.mem
s r.rule_info
.used_after
&&
1485 not
(List.mem
s old_variables)))) in
1487 (function new_binding_to_add
->
1490 old_bindings_to_keep new_binding_to_add
),
1491 r.rule_info
.rulename
::rules_that_have_matched
))
1492 new_bindings_to_add in
1493 ((relevant_bindings,new_bindings)::cache
,
1494 merge_env new_e newes
))
1495 ([],[]) reorganized_env in (* end iter es *)
1496 if !(r.rule_info
.was_matched
)
1497 then Common.push2
r.rule_info
.rulename rules_that_have_ever_matched
;
1501 (* apply the tagged modifs and reparse *)
1502 if not
!Flag.sgrep_mode2
1503 then ccs
:= rebuild_info_c_and_headers !ccs
r.isexp
)
1505 and reassociate_positions free_vars negated_pos_vars envs
=
1506 (* issues: isolate the bindings that are relevant to a given rule.
1507 separate out the position variables
1508 associate all of the position variables for a given set of relevant
1509 normal variable bindings with each set of relevant normal variable
1510 bindings. Goal: if eg if@p (E) matches in two places, then both inherited
1511 occurrences of E should see both bindings of p, not just its own.
1512 Otherwise, a position constraint for something that matches in two
1513 places will never be useful, because the position can always be
1514 different from the other one. *)
1518 List.filter
(function (x
,_) -> List.mem x free_vars
) e)
1520 let splitted_relevant =
1521 (* separate the relevant variables into the non-position ones and the
1526 (function (non_pos
,pos
) ->
1527 function (v
,_) as x
->
1528 if List.mem v negated_pos_vars
1529 then (non_pos
,x
::pos
)
1530 else (x
::non_pos
,pos
))
1533 let splitted_relevant =
1535 (function (non_pos
,pos
) ->
1536 (List.sort compare non_pos
,List.sort compare pos
))
1537 splitted_relevant in
1540 (function non_pos
->
1542 if List.mem np non_pos
then non_pos
else np
::non_pos
)
1543 [] splitted_relevant in
1544 let extended_relevant =
1545 (* extend the position variables with the values found at other identical
1546 variable bindings *)
1548 (function non_pos
->
1551 (function (other_non_pos
,other_pos
) ->
1552 (* do we want equal? or just somehow compatible? eg non_pos
1553 binds only E, but other_non_pos binds both E and E1 *)
1554 non_pos
=*= other_non_pos
)
1555 splitted_relevant in
1559 (combine_pos negated_pos_vars
1560 (List.map
(function (_,x
) -> x
) others)))))
1563 (List.map
(function (non_pos
,_) -> List.assoc non_pos
extended_relevant)
1566 (* If the negated posvar is not bound at all, this function will
1567 nevertheless bind it to []. If we get rid of these bindings, then the
1568 matching of the term the position variable with the constraints will fail
1569 because some variables are unbound. So we let the binding be [] and then
1570 we will have to clean these up afterwards. This should be the only way
1571 that a position variable can have an empty binding. *)
1572 and combine_pos negated_pos_vars
others =
1578 (function positions ->
1579 function other_list
->
1581 match List.assoc posvar other_list
with
1582 Ast_c.MetaPosValList l1
->
1583 Common.union_set l1
positions
1584 | _ -> failwith
"bad value for a position variable"
1585 with Not_found
-> positions)
1587 (posvar
,Ast_c.MetaPosValList
positions))
1590 and process_a_generated_a_env_a_toplevel2
r env = function
1595 (rule
,_) when rule
=$
= r.rule_info
.rulename
-> false
1596 | (_,"ARGS") -> false
1599 let env_domain = List.map
(function (nm
,vl
) -> nm
) env in
1603 let (rl
,_) = Ast_cocci.get_meta_name md
in rl
=$
= r.rule_info
.rulename
)
1605 if Common.include_set
free_vars env_domain
1606 then Unparse_hrule.pp_rule
metavars r.ast_rule
env cfile
.full_fname
1607 | _ -> failwith
"multiple files not supported"
1609 and process_a_generated_a_env_a_toplevel rule
env ccs
=
1610 Common.profile_code
"process_a_ctl_a_env_a_toplevel"
1611 (fun () -> process_a_generated_a_env_a_toplevel2 rule
env ccs
)
1613 (* does side effects on C ast and on Cocci info rule *)
1614 and process_a_ctl_a_env_a_toplevel2
r e c
f =
1615 indent_do
(fun () ->
1616 show_or_not_celem "trying" c
.ast_c
;
1617 Flag.currentfile
:= Some
(f ^
":" ^
get_celem c
.ast_c
);
1618 match (r.ctl
,c
.ast_c
) with
1619 ((Asttoctl2.NONDECL ctl
,t
),Ast_c.Declaration
_) -> None
1620 | ((Asttoctl2.NONDECL ctl
,t
), _)
1621 | ((Asttoctl2.CODE ctl
,t
), _) ->
1622 let ctl = (ctl,t
) in (* ctl and other info *)
1623 let (trans_info, returned_any_states
, inherited_bindings
, newbindings
) =
1624 Common.save_excursion
Flag_ctl.loop_in_src_code
(fun () ->
1625 Flag_ctl.loop_in_src_code
:=
1626 !Flag_ctl.loop_in_src_code
||c
.contain_loop;
1628 (***************************************)
1629 (* !Main point! The call to the engine *)
1630 (***************************************)
1632 CCI.model_for_ctl
r.dropped_isos
(Common.some c
.flow) e
1633 in CCI.mysat
model_ctl ctl (r.rule_info
.used_after
, e))
1635 if not returned_any_states
1639 show_or_not_celem "found match in" c
.ast_c
;
1640 show_or_not_trans_info trans_info;
1641 List.iter
(show_or_not_binding "out") newbindings
;
1643 r.rule_info
.was_matched
:= true;
1645 if not
(null
trans_info) &&
1646 not
(!Flag.sgrep_mode2
&& not
!Flag_cocci.show_diff
)
1649 c
.was_modified
:= true;
1651 (* les "more than one var in a decl" et "already tagged token"
1652 * font crasher coccinelle. Si on a 5 fichiers, donc on a 5
1653 * failed. Le try limite le scope des crashes pendant la
1654 * trasformation au fichier concerne. *)
1656 (* modify ast via side effect *)
1658 (Transformation_c.transform
r.rule_info
.rulename
1660 inherited_bindings
trans_info (Common.some c
.flow));
1661 with Timeout
-> raise Timeout
| UnixExit i
-> raise
(UnixExit i
)
1664 Some
(List.map
(function x
-> x
@inherited_bindings
) newbindings
)
1668 and process_a_ctl_a_env_a_toplevel a b c
f=
1669 Common.profile_code
"process_a_ctl_a_env_a_toplevel"
1670 (fun () -> process_a_ctl_a_env_a_toplevel2 a b c
f)
1673 let rec bigloop2 rs
(ccs
: file_info list
) =
1674 let init_es = [(Ast_c.emptyMetavarsBinding
,[])] in
1675 let es = ref init_es in
1676 let ccs = ref ccs in
1677 let rules_that_have_ever_matched = ref [] in
1679 (* looping over the rules *)
1680 rs
+> List.iter
(fun r ->
1682 InitialScriptRuleCocciInfo
r | FinalScriptRuleCocciInfo
r -> ()
1683 | ScriptRuleCocciInfo
r ->
1684 if !Flag_cocci.show_ctl_text
then begin
1685 Common.pr_xxxxxxxxxxxxxxxxx
();
1686 pr
("script: " ^
r.language
);
1687 Common.pr_xxxxxxxxxxxxxxxxx
();
1689 adjust_pp_with_indent
(fun () ->
1690 Format.force_newline
();
1691 let (l,mv,script_vars
,code
) = r.scr_ast_rule
in
1692 let nm = r.scr_rule_info
.rulename
in
1693 let deps = r.scr_rule_info
.dependencies
in
1694 Pretty_print_cocci.unparse
1695 (Ast_cocci.ScriptRule
(nm,l,deps,mv,script_vars
,code
)));
1698 if !Flag.show_misc
then print_endline
"RESULT =";
1702 (function (cache
, newes
) ->
1703 function (e, rules_that_have_matched
) ->
1704 match r.language
with
1706 apply_script_rule r cache newes
e rules_that_have_matched
1707 rules_that_have_ever_matched python_application
1709 apply_script_rule r cache newes
e rules_that_have_matched
1710 rules_that_have_ever_matched ocaml_application
1712 concat_headers_and_c !ccs +> List.iter
(fun (c
,_) ->
1715 Printf.printf
"Flow: %s\r\nFlow!\r\n%!" c
.fullstring
);
1718 Printf.printf
"Unknown language: %s\n" r.language
;
1722 (if !(r.scr_rule_info
.was_matched
)
1724 Common.push2
r.scr_rule_info
.rulename
rules_that_have_ever_matched);
1726 es := newes
(*(if newes = [] then init_es else newes)*);
1727 | CocciRuleCocciInfo
r ->
1728 apply_cocci_rule r rules_that_have_ever_matched
1731 if !Flag.sgrep_mode2
1733 (* sgrep can lead to code that is not parsable, but we must
1734 * still call rebuild_info_c_and_headers to pretty print the
1735 * action (MINUS), so that later the diff will show what was
1736 * matched by sgrep. But we don't want the parsing error message
1737 * hence the following flag setting. So this code propably
1738 * will generate a NotParsedCorrectly for the matched parts
1739 * and the very final pretty print and diff will work
1741 Flag_parsing_c.verbose_parsing
:= false;
1742 ccs := rebuild_info_c_and_headers !ccs false
1744 !ccs (* return final C asts *)
1747 Common.profile_code
"bigloop" (fun () -> bigloop2 a b
)
1749 type init_final
= Initial
| Final
1751 let initial_final_bigloop2 ty rebuild
r =
1752 if !Flag_cocci.show_ctl_text
then
1754 Common.pr_xxxxxxxxxxxxxxxxx
();
1755 pr
((match ty
with Initial
-> "initial" | Final
-> "final") ^
": " ^
1757 Common.pr_xxxxxxxxxxxxxxxxx
();
1759 adjust_pp_with_indent
(fun () ->
1760 Format.force_newline
();
1761 Pretty_print_cocci.unparse
(rebuild
r.scr_ast_rule
r.scr_rule_info
.dependencies
));
1764 match r.language
with
1766 (* include_match makes no sense in an initial or final rule, although
1767 we have no way to prevent it *)
1768 let _ = apply_script_rule r [] [] [] [] (ref []) python_application in
1770 | "ocaml" when ty
= Initial
-> () (* nothing to do *)
1772 (* include_match makes no sense in an initial or final rule, although
1773 we have no way to prevent it *)
1774 let _ = apply_script_rule r [] [] [] [] (ref []) ocaml_application in
1777 failwith
("Unknown language for initial/final script: "^
1780 let initial_final_bigloop a b c
=
1781 Common.profile_code
"initial_final_bigloop"
1782 (fun () -> initial_final_bigloop2 a b c
)
1784 (*****************************************************************************)
1785 (* The main functions *)
1786 (*****************************************************************************)
1788 let pre_engine2 (coccifile
, isofile
) =
1789 show_or_not_cocci coccifile isofile
;
1790 Pycocci.set_coccifile coccifile
;
1793 if not
(Common.lfile_exists
isofile)
1795 pr2
("warning: Can't find default iso file: " ^
isofile);
1798 else Some
isofile in
1800 (* useful opti when use -dir *)
1801 let (metavars,astcocci
,
1802 free_var_lists
,negated_pos_lists
,used_after_lists
,
1803 positions_lists
,(toks
,_,_)) =
1804 sp_of_file coccifile
isofile in
1805 let ctls = ctls_of_ast astcocci used_after_lists positions_lists
in
1807 g_contain_typedmetavar := sp_contain_typed_metavar astcocci
;
1809 check_macro_in_sp_and_adjust toks
;
1811 show_or_not_ctl_tex astcocci
ctls;
1814 prepare_cocci ctls free_var_lists negated_pos_lists
1815 used_after_lists positions_lists
metavars astcocci
in
1817 let used_languages =
1819 (function languages
->
1821 ScriptRuleCocciInfo
(r) ->
1822 if List.mem
r.language languages
then
1825 r.language
::languages
1830 let rlang = r.language
in
1831 let rname = r.scr_rule_info
.rulename
in
1833 let _ = List.assoc
(rlang,rname) !Iteration.initialization_stack
in
1837 Iteration.initialization_stack
:=
1838 ((rlang,rname),!Flag.defined_virtual_rules
) ::
1839 !Iteration.initialization_stack
;
1840 initial_final_bigloop Initial
1841 (fun (x
,_,_,y
) -> fun deps ->
1842 Ast_cocci.InitialScriptRule
(rname,x
,deps,y
))
1846 let initialized_languages =
1848 (function languages
->
1850 InitialScriptRuleCocciInfo
(r) ->
1851 let rlang = r.language
in
1852 (if List.mem
rlang languages
1853 then failwith
("double initializer found for "^
rlang));
1854 if interpret_dependencies [] [] r.scr_rule_info
.dependencies
1855 then begin runrule r; rlang::languages
end
1860 let uninitialized_languages =
1862 (fun used
-> not
(List.mem used
initialized_languages))
1869 dependencies
= Ast_cocci.NoDep
;
1872 was_matched
= ref false;} in
1873 runrule (make_init lgg
"" rule_info))
1874 uninitialized_languages;
1879 Common.profile_code
"pre_engine" (fun () -> pre_engine2 a
)
1881 let full_engine2 (cocci_infos,toks
) cfiles =
1883 show_or_not_cfiles cfiles;
1885 (* optimisation allowing to launch coccinelle on all the drivers *)
1886 if !Flag_cocci.worth_trying_opt
&& not
(worth_trying cfiles toks
)
1892 pr2
("No matches found for " ^
(Common.join
" " toks
)
1893 ^
"\nSkipping:" ^
(Common.join
" " cfiles)));
1894 cfiles +> List.map
(fun s -> s, None
)
1899 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1900 if !Flag.show_misc
then pr
"let's go";
1901 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1903 let choose_includes =
1904 match !Flag_cocci.include_options
with
1905 Flag_cocci.I_UNSPECIFIED
->
1906 if !g_contain_typedmetavar
1907 then Flag_cocci.I_NORMAL_INCLUDES
1908 else Flag_cocci.I_NO_INCLUDES
1910 let c_infos = prepare_c cfiles choose_includes in
1912 (* ! the big loop ! *)
1913 let c_infos'
= bigloop cocci_infos c_infos in
1915 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1916 if !Flag.show_misc
then pr
"Finished";
1917 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1918 if !Flag_ctl.graphical_trace
then gen_pdf_graph ();
1920 c_infos'
+> List.map
(fun c_or_h
->
1921 if !(c_or_h
.was_modified_once
)
1925 Common.new_temp_file
"cocci-output" ("-" ^ c_or_h
.fname
) in
1927 if c_or_h
.fkind
=*= Header
1928 then pr2
("a header file was modified: " ^ c_or_h
.fname
);
1930 (* and now unparse everything *)
1931 cfile_of_program (for_unparser c_or_h
.asts
) outfile;
1933 show_or_not_diff c_or_h
.fpath
outfile;
1936 if !Flag.sgrep_mode2
then None
else Some
outfile)
1938 else (c_or_h
.fpath
, None
))
1941 let full_engine a b
=
1942 Common.profile_code
"full_engine"
1943 (fun () -> let res = full_engine2 a b
in (*Gc.print_stat stderr; *)res)
1945 let post_engine2 (cocci_infos,_) =
1947 (function ((language
,_),virt_rules
) ->
1948 Flag.defined_virtual_rules
:= virt_rules
;
1951 (function languages
->
1953 FinalScriptRuleCocciInfo
(r) ->
1954 (if r.language
= language
&& List.mem
r.language languages
1955 then failwith
("double finalizer found for "^
r.language
));
1956 initial_final_bigloop Final
1957 (fun (x
,_,_,y
) -> fun deps ->
1958 Ast_cocci.FinalScriptRule
(r.scr_rule_info
.rulename
,
1961 r.language
::languages
1965 !Iteration.initialization_stack
1968 Common.profile_code
"post_engine" (fun () -> post_engine2 a
)
1970 (*****************************************************************************)
1971 (* check duplicate from result of full_engine *)
1972 (*****************************************************************************)
1974 let check_duplicate_modif2 xs =
1975 (* opti: let groups = Common.groupBy (fun (a,resa) (b,resb) -> a =$= b) xs *)
1976 if !Flag_cocci.verbose_cocci
1977 then pr2
("Check duplication for " ^ i_to_s
(List.length
xs) ^
" files");
1979 let groups = Common.group_assoc_bykey_eff
xs in
1980 groups +> Common.map_filter
(fun (file, xs) ->
1982 | [] -> raise Impossible
1983 | [res] -> Some
(file, res)
1987 if not
(List.for_all
(fun res2
-> res2
=*= None
) xs)
1989 pr2
("different modification result for " ^
file);
1992 else Some
(file, None
)
1994 if not
(List.for_all
(fun res2
->
1998 let diff = Common.cmd_to_list
("diff -u -b -B "^
res^
" "^res2
)
2002 pr2
("different modification result for " ^
file);
2005 else Some
(file, Some
res)
2007 let check_duplicate_modif a
=
2008 Common.profile_code
"check_duplicate" (fun () -> check_duplicate_modif2 a
)