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
1254 let python_application mv ve script_vars
r =
1258 ((Some x
,None
),y
,z
) -> (x
,y
,z
)
1261 (Printf.sprintf
"unexpected ast metavar in rule %s"
1262 r.scr_rule_info
.rulename
))
1265 Pycocci.build_classes
(List.map
(function (x
,y
) -> x
) ve
);
1266 Pycocci.construct_variables
mv ve
;
1267 Pycocci.construct_script_variables script_vars
;
1268 let _ = Pycocci.pyrun_simplestring
(local_python_code ^
r.script_code
) in
1271 else if !Pycocci.inc_match
1272 then Some
(Pycocci.retrieve_script_variables script_vars
)
1274 with Pycocci.Pycocciexception
->
1275 (pr2
("Failure in " ^
r.scr_rule_info
.rulename
);
1276 raise
Pycocci.Pycocciexception
)
1278 let ocaml_application mv ve script_vars
r =
1281 Run_ocamlcocci.run
mv ve script_vars
1282 r.scr_rule_info
.rulename
r.script_code
in
1285 else if !Coccilib.inc_match
1286 then Some
script_vals
1288 with e
-> (pr2
("Failure in " ^
r.scr_rule_info
.rulename
); raise e
)
1290 (* returns Left in case of dependency failure, Right otherwise *)
1291 let apply_script_rule r cache newes e rules_that_have_matched
1292 rules_that_have_ever_matched script_application
=
1293 Common.profile_code
r.language
(fun () ->
1294 show_or_not_scr_rule_name r.scr_rule_info
.ruleid
;
1295 if not
(interpret_dependencies rules_that_have_matched
1296 !rules_that_have_ever_matched
r.scr_rule_info
.dependencies
)
1299 print_dependencies "dependencies for script not satisfied:"
1300 rules_that_have_matched
1301 !rules_that_have_ever_matched
r.scr_rule_info
.dependencies
;
1302 show_or_not_binding "in environment" e
;
1303 (cache
, (e
, rules_that_have_matched
)::newes
)
1307 let (_, mv, script_vars
, _) = r.scr_ast_rule
in
1309 (List.map
(function (n
,v
) -> (("virtual",n
),Ast_c.MetaIdVal
(v
,[])))
1310 !Flag.defined_virtual_env
) @ e
in
1311 let not_bound x
= not
(contains_binding ve x
) in
1312 (match List.filter
not_bound mv with
1314 let relevant_bindings =
1316 (function ((re
,rm
),_) ->
1317 List.exists
(function (_,(r,m
),_) -> r =*= re
&& m
=$
= rm
) mv)
1320 match List.assoc
relevant_bindings cache
with
1321 None
-> (cache
,newes
)
1322 | Some
script_vals ->
1324 "dependencies for script satisfied, but cached:"
1325 rules_that_have_matched
1326 !rules_that_have_ever_matched
1327 r.scr_rule_info
.dependencies
;
1328 show_or_not_binding "in" e
;
1329 (* env might be bigger than what was cached against, so have to
1330 merge with newes anyway *)
1331 let new_e = (List.combine script_vars
script_vals) @ e
in
1335 (fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1336 (cache
,merge_env [(new_e, rules_that_have_matched
)] newes
)
1339 print_dependencies "dependencies for script satisfied:"
1340 rules_that_have_matched
1341 !rules_that_have_ever_matched
1342 r.scr_rule_info
.dependencies
;
1343 show_or_not_binding "in" e
;
1344 match script_application
mv ve script_vars
r with
1346 (* failure means we should drop e, no new bindings *)
1347 (((relevant_bindings,None
) :: cache
), newes
)
1348 | Some
script_vals ->
1350 List.map
(function x
-> Ast_c.MetaIdVal
(x
,[]))
1353 (List.combine script_vars
script_vals) @ e
in
1357 (fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1358 r.scr_rule_info
.was_matched
:= true;
1359 (((relevant_bindings,Some
script_vals) :: cache
),
1362 r.scr_rule_info
.rulename
:: rules_that_have_matched
)]
1366 (if !Flag_cocci.show_dependencies
1368 let m2c (_,(r,x
),_) = r^
"."^x
in
1369 pr2
(Printf.sprintf
"script not applied: %s not bound"
1370 (String.concat
", " (List.map
m2c unbound
))));
1374 (fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1375 (cache
, merge_env [(e, rules_that_have_matched
)] newes
))
1378 let rec apply_cocci_rule r rules_that_have_ever_matched es
1379 (ccs
:file_info list
ref) =
1380 Common.profile_code
r.rule_info
.rulename
(fun () ->
1381 show_or_not_rule_name r.ast_rule
r.rule_info
.ruleid
;
1382 show_or_not_ctl_text r.ctl
r.ast_rule
r.rule_info
.ruleid
;
1384 let reorganized_env =
1385 reassociate_positions
r.free_vars
r.negated_pos_vars
!es
in
1387 (* looping over the environments *)
1388 let (_,newes
(* envs for next round/rule *)) =
1390 (function (cache
,newes
) ->
1391 function ((e,rules_that_have_matched
),relevant_bindings) ->
1392 if not
(interpret_dependencies rules_that_have_matched
1393 !rules_that_have_ever_matched
1394 r.rule_info
.dependencies
)
1398 ("dependencies for rule "^
r.rule_info
.rulename^
1400 rules_that_have_matched
1401 !rules_that_have_ever_matched
r.rule_info
.dependencies
;
1402 show_or_not_binding "in environment" e;
1407 (fun (s,v
) -> List.mem
s r.rule_info
.used_after
),
1408 rules_that_have_matched
)]
1413 try List.assoc
relevant_bindings cache
1417 ("dependencies for rule "^
r.rule_info
.rulename^
1419 rules_that_have_matched
1420 !rules_that_have_ever_matched
1421 r.rule_info
.dependencies
;
1422 show_or_not_binding "in" e;
1423 show_or_not_binding "relevant in" relevant_bindings;
1425 (* applying the rule *)
1426 (match r.ruletype
with
1428 (* looping over the functions and toplevel elements in
1431 (concat_headers_and_c !ccs
+>
1432 List.fold_left
(fun children_e
(c
,f) ->
1435 (* does also some side effects on c and r *)
1437 process_a_ctl_a_env_a_toplevel
r
1438 relevant_bindings c
f in
1439 match processed with
1440 | None
-> children_e
1441 | Some newbindings
->
1444 (fun children_e newbinding
->
1445 if List.mem newbinding children_e
1447 else newbinding
:: children_e
)
1451 | Ast_cocci.Generated
->
1452 process_a_generated_a_env_a_toplevel
r
1453 relevant_bindings !ccs
;
1456 let old_bindings_to_keep =
1460 (fun (s,v
) -> List.mem
s r.rule_info
.used_after
)) in
1462 if null
new_bindings
1465 (*use the old bindings, specialized to the used_after_list*)
1466 if !Flag_ctl.partial_match
1469 "Empty list of bindings, I will restart from old env\n";
1470 [(old_bindings_to_keep,rules_that_have_matched
)]
1473 (* combine the new bindings with the old ones, and
1474 specialize to the used_after_list *)
1475 let old_variables = List.map fst
old_bindings_to_keep in
1476 (* have to explicitly discard the inherited variables
1477 because we want the inherited value of the positions
1478 variables not the extended one created by
1479 reassociate_positions. want to reassociate freshly
1480 according to the free variables of each rule. *)
1481 let new_bindings_to_add =
1487 (* see comment before combine_pos *)
1488 (s,Ast_c.MetaPosValList
[]) -> false
1490 List.mem
s r.rule_info
.used_after
&&
1491 not
(List.mem
s old_variables)))) in
1493 (function new_binding_to_add
->
1496 old_bindings_to_keep new_binding_to_add
),
1497 r.rule_info
.rulename
::rules_that_have_matched
))
1498 new_bindings_to_add in
1499 ((relevant_bindings,new_bindings)::cache
,
1500 merge_env new_e newes
))
1501 ([],[]) reorganized_env in (* end iter es *)
1502 if !(r.rule_info
.was_matched
)
1503 then Common.push2
r.rule_info
.rulename rules_that_have_ever_matched
;
1507 (* apply the tagged modifs and reparse *)
1508 if not
!Flag.sgrep_mode2
1509 then ccs
:= rebuild_info_c_and_headers !ccs
r.isexp
)
1511 and reassociate_positions free_vars negated_pos_vars envs
=
1512 (* issues: isolate the bindings that are relevant to a given rule.
1513 separate out the position variables
1514 associate all of the position variables for a given set of relevant
1515 normal variable bindings with each set of relevant normal variable
1516 bindings. Goal: if eg if@p (E) matches in two places, then both inherited
1517 occurrences of E should see both bindings of p, not just its own.
1518 Otherwise, a position constraint for something that matches in two
1519 places will never be useful, because the position can always be
1520 different from the other one. *)
1524 List.filter
(function (x
,_) -> List.mem x free_vars
) e)
1526 let splitted_relevant =
1527 (* separate the relevant variables into the non-position ones and the
1532 (function (non_pos
,pos
) ->
1533 function (v
,_) as x
->
1534 if List.mem v negated_pos_vars
1535 then (non_pos
,x
::pos
)
1536 else (x
::non_pos
,pos
))
1539 let splitted_relevant =
1541 (function (non_pos
,pos
) ->
1542 (List.sort compare non_pos
,List.sort compare pos
))
1543 splitted_relevant in
1546 (function non_pos
->
1548 if List.mem np non_pos
then non_pos
else np
::non_pos
)
1549 [] splitted_relevant in
1550 let extended_relevant =
1551 (* extend the position variables with the values found at other identical
1552 variable bindings *)
1554 (function non_pos
->
1557 (function (other_non_pos
,other_pos
) ->
1558 (* do we want equal? or just somehow compatible? eg non_pos
1559 binds only E, but other_non_pos binds both E and E1 *)
1560 non_pos
=*= other_non_pos
)
1561 splitted_relevant in
1565 (combine_pos negated_pos_vars
1566 (List.map
(function (_,x
) -> x
) others)))))
1569 (List.map
(function (non_pos
,_) -> List.assoc non_pos
extended_relevant)
1572 (* If the negated posvar is not bound at all, this function will
1573 nevertheless bind it to []. If we get rid of these bindings, then the
1574 matching of the term the position variable with the constraints will fail
1575 because some variables are unbound. So we let the binding be [] and then
1576 we will have to clean these up afterwards. This should be the only way
1577 that a position variable can have an empty binding. *)
1578 and combine_pos negated_pos_vars
others =
1584 (function positions ->
1585 function other_list
->
1587 match List.assoc posvar other_list
with
1588 Ast_c.MetaPosValList l1
->
1589 Common.union_set l1
positions
1590 | _ -> failwith
"bad value for a position variable"
1591 with Not_found
-> positions)
1593 (posvar
,Ast_c.MetaPosValList
positions))
1596 and process_a_generated_a_env_a_toplevel2
r env = function
1601 (rule
,_) when rule
=$
= r.rule_info
.rulename
-> false
1602 | (_,"ARGS") -> false
1605 let env_domain = List.map
(function (nm
,vl
) -> nm
) env in
1609 let (rl
,_) = Ast_cocci.get_meta_name md
in rl
=$
= r.rule_info
.rulename
)
1611 if Common.include_set
free_vars env_domain
1612 then Unparse_hrule.pp_rule
metavars r.ast_rule
env cfile
.full_fname
1613 | _ -> failwith
"multiple files not supported"
1615 and process_a_generated_a_env_a_toplevel rule
env ccs
=
1616 Common.profile_code
"process_a_ctl_a_env_a_toplevel"
1617 (fun () -> process_a_generated_a_env_a_toplevel2 rule
env ccs
)
1619 (* does side effects on C ast and on Cocci info rule *)
1620 and process_a_ctl_a_env_a_toplevel2
r e c
f =
1621 indent_do
(fun () ->
1622 show_or_not_celem "trying" c
.ast_c
;
1623 Flag.currentfile
:= Some
(f ^
":" ^
get_celem c
.ast_c
);
1624 match (r.ctl
,c
.ast_c
) with
1625 ((Asttoctl2.NONDECL ctl
,t
),Ast_c.Declaration
_) -> None
1626 | ((Asttoctl2.NONDECL ctl
,t
), _)
1627 | ((Asttoctl2.CODE ctl
,t
), _) ->
1628 let ctl = (ctl,t
) in (* ctl and other info *)
1629 let (trans_info, returned_any_states
, inherited_bindings
, newbindings
) =
1630 Common.save_excursion
Flag_ctl.loop_in_src_code
(fun () ->
1631 Flag_ctl.loop_in_src_code
:=
1632 !Flag_ctl.loop_in_src_code
||c
.contain_loop;
1634 (***************************************)
1635 (* !Main point! The call to the engine *)
1636 (***************************************)
1638 CCI.model_for_ctl
r.dropped_isos
(Common.some c
.flow) e
1639 in CCI.mysat
model_ctl ctl (r.rule_info
.used_after
, e))
1641 if not returned_any_states
1645 show_or_not_celem "found match in" c
.ast_c
;
1646 show_or_not_trans_info trans_info;
1647 List.iter
(show_or_not_binding "out") newbindings
;
1649 r.rule_info
.was_matched
:= true;
1651 if not
(null
trans_info) &&
1652 not
(!Flag.sgrep_mode2
&& not
!Flag_cocci.show_diff
)
1655 c
.was_modified
:= true;
1657 (* les "more than one var in a decl" et "already tagged token"
1658 * font crasher coccinelle. Si on a 5 fichiers, donc on a 5
1659 * failed. Le try limite le scope des crashes pendant la
1660 * trasformation au fichier concerne. *)
1662 (* modify ast via side effect *)
1664 (Transformation_c.transform
r.rule_info
.rulename
1666 inherited_bindings
trans_info (Common.some c
.flow));
1667 with Timeout
-> raise Timeout
| UnixExit i
-> raise
(UnixExit i
)
1670 Some
(List.map
(function x
-> x
@inherited_bindings
) newbindings
)
1674 and process_a_ctl_a_env_a_toplevel a b c
f=
1675 Common.profile_code
"process_a_ctl_a_env_a_toplevel"
1676 (fun () -> process_a_ctl_a_env_a_toplevel2 a b c
f)
1679 let rec bigloop2 rs
(ccs
: file_info list
) =
1680 let init_es = [(Ast_c.emptyMetavarsBinding
,[])] in
1681 let es = ref init_es in
1682 let ccs = ref ccs in
1683 let rules_that_have_ever_matched = ref [] in
1687 (* looping over the rules *)
1688 rs
+> List.iter
(fun r ->
1690 InitialScriptRuleCocciInfo
r | FinalScriptRuleCocciInfo
r -> ()
1691 | ScriptRuleCocciInfo
r ->
1692 if !Flag_cocci.show_ctl_text
then begin
1693 Common.pr_xxxxxxxxxxxxxxxxx
();
1694 pr
("script: " ^
r.language
);
1695 Common.pr_xxxxxxxxxxxxxxxxx
();
1697 adjust_pp_with_indent
(fun () ->
1698 Format.force_newline
();
1699 let (l,mv,script_vars
,code
) = r.scr_ast_rule
in
1700 let nm = r.scr_rule_info
.rulename
in
1701 let deps = r.scr_rule_info
.dependencies
in
1702 Pretty_print_cocci.unparse
1703 (Ast_cocci.ScriptRule
(nm,l,deps,mv,script_vars
,code
)));
1706 if !Flag.show_misc
then print_endline
"RESULT =";
1710 (function (cache
, newes
) ->
1711 function (e, rules_that_have_matched
) ->
1712 match r.language
with
1714 apply_script_rule r cache newes
e rules_that_have_matched
1715 rules_that_have_ever_matched python_application
1717 apply_script_rule r cache newes
e rules_that_have_matched
1718 rules_that_have_ever_matched ocaml_application
1720 concat_headers_and_c !ccs +> List.iter
(fun (c
,_) ->
1723 Printf.printf
"Flow: %s\r\nFlow!\r\n%!" c
.fullstring
);
1726 Printf.printf
"Unknown language: %s\n" r.language
;
1730 (if !(r.scr_rule_info
.was_matched
)
1732 Common.push2
r.scr_rule_info
.rulename
rules_that_have_ever_matched);
1734 (* just newes can't work, because if one does include_match false
1735 on everything that binds a variable, then nothing is left *)
1736 es := (*newes*) (if newes
= [] then init_es else newes
)
1737 | CocciRuleCocciInfo
r ->
1738 apply_cocci_rule r rules_that_have_ever_matched
1742 if !Flag.sgrep_mode2
1744 (* sgrep can lead to code that is not parsable, but we must
1745 * still call rebuild_info_c_and_headers to pretty print the
1746 * action (MINUS), so that later the diff will show what was
1747 * matched by sgrep. But we don't want the parsing error message
1748 * hence the following flag setting. So this code propably
1749 * will generate a NotParsedCorrectly for the matched parts
1750 * and the very final pretty print and diff will work
1752 Flag_parsing_c.verbose_parsing
:= false;
1753 ccs := rebuild_info_c_and_headers !ccs false
1755 !ccs (* return final C asts *)
1758 Common.profile_code
"bigloop" (fun () -> bigloop2 a b
)
1760 type init_final
= Initial
| Final
1762 let initial_final_bigloop2 ty rebuild
r =
1763 if !Flag_cocci.show_ctl_text
then
1765 Common.pr_xxxxxxxxxxxxxxxxx
();
1766 pr
((match ty
with Initial
-> "initial" | Final
-> "final") ^
": " ^
1768 Common.pr_xxxxxxxxxxxxxxxxx
();
1770 adjust_pp_with_indent
(fun () ->
1771 Format.force_newline
();
1772 Pretty_print_cocci.unparse
(rebuild
r.scr_ast_rule
r.scr_rule_info
.dependencies
));
1775 match r.language
with
1777 (* include_match makes no sense in an initial or final rule, although
1778 we have no way to prevent it *)
1779 let _ = apply_script_rule r [] [] [] [] (ref []) python_application in
1781 | "ocaml" when ty
= Initial
-> () (* nothing to do *)
1783 (* include_match makes no sense in an initial or final rule, although
1784 we have no way to prevent it *)
1785 let _ = apply_script_rule r [] [] [] [] (ref []) ocaml_application in
1788 failwith
("Unknown language for initial/final script: "^
1791 let initial_final_bigloop a b c
=
1792 Common.profile_code
"initial_final_bigloop"
1793 (fun () -> initial_final_bigloop2 a b c
)
1795 (*****************************************************************************)
1796 (* The main functions *)
1797 (*****************************************************************************)
1799 let pre_engine2 (coccifile
, isofile
) =
1800 show_or_not_cocci coccifile isofile
;
1801 Pycocci.set_coccifile coccifile
;
1804 if not
(Common.lfile_exists
isofile)
1806 pr2
("warning: Can't find default iso file: " ^
isofile);
1809 else Some
isofile in
1811 (* useful opti when use -dir *)
1812 let (metavars,astcocci
,
1813 free_var_lists
,negated_pos_lists
,used_after_lists
,
1814 positions_lists
,(toks
,_,_)) =
1815 sp_of_file coccifile
isofile in
1816 let ctls = ctls_of_ast astcocci used_after_lists positions_lists
in
1818 g_contain_typedmetavar := sp_contain_typed_metavar astcocci
;
1820 check_macro_in_sp_and_adjust toks
;
1822 show_or_not_ctl_tex astcocci
ctls;
1825 prepare_cocci ctls free_var_lists negated_pos_lists
1826 used_after_lists positions_lists
metavars astcocci
in
1828 let used_languages =
1830 (function languages
->
1832 ScriptRuleCocciInfo
(r) ->
1833 if List.mem
r.language languages
then
1836 r.language
::languages
1841 let rlang = r.language
in
1842 let rname = r.scr_rule_info
.rulename
in
1844 let _ = List.assoc
(rlang,rname) !Iteration.initialization_stack
in
1848 Iteration.initialization_stack
:=
1849 ((rlang,rname),!Flag.defined_virtual_rules
) ::
1850 !Iteration.initialization_stack
;
1851 initial_final_bigloop Initial
1852 (fun (x
,_,_,y
) -> fun deps ->
1853 Ast_cocci.InitialScriptRule
(rname,x
,deps,y
))
1857 let initialized_languages =
1859 (function languages
->
1861 InitialScriptRuleCocciInfo
(r) ->
1862 let rlang = r.language
in
1863 (if List.mem
rlang languages
1864 then failwith
("double initializer found for "^
rlang));
1865 if interpret_dependencies [] [] r.scr_rule_info
.dependencies
1866 then begin runrule r; rlang::languages
end
1871 let uninitialized_languages =
1873 (fun used
-> not
(List.mem used
initialized_languages))
1880 dependencies
= Ast_cocci.NoDep
;
1883 was_matched
= ref false;} in
1884 runrule (make_init lgg
"" rule_info))
1885 uninitialized_languages;
1890 Common.profile_code
"pre_engine" (fun () -> pre_engine2 a
)
1892 let full_engine2 (cocci_infos,toks
) cfiles =
1894 show_or_not_cfiles cfiles;
1896 (* optimisation allowing to launch coccinelle on all the drivers *)
1897 if !Flag_cocci.worth_trying_opt
&& not
(worth_trying cfiles toks
)
1903 pr2
("No matches found for " ^
(Common.join
" " toks
)
1904 ^
"\nSkipping:" ^
(Common.join
" " cfiles)));
1905 cfiles +> List.map
(fun s -> s, None
)
1910 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1911 if !Flag.show_misc
then pr
"let's go";
1912 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1914 let choose_includes =
1915 match !Flag_cocci.include_options
with
1916 Flag_cocci.I_UNSPECIFIED
->
1917 if !g_contain_typedmetavar
1918 then Flag_cocci.I_NORMAL_INCLUDES
1919 else Flag_cocci.I_NO_INCLUDES
1921 let c_infos = prepare_c cfiles choose_includes in
1923 (* ! the big loop ! *)
1924 let c_infos'
= bigloop cocci_infos c_infos in
1926 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1927 if !Flag.show_misc
then pr
"Finished";
1928 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1929 if !Flag_ctl.graphical_trace
then gen_pdf_graph ();
1931 c_infos'
+> List.map
(fun c_or_h
->
1932 if !(c_or_h
.was_modified_once
)
1936 Common.new_temp_file
"cocci-output" ("-" ^ c_or_h
.fname
) in
1938 if c_or_h
.fkind
=*= Header
1939 then pr2
("a header file was modified: " ^ c_or_h
.fname
);
1941 (* and now unparse everything *)
1942 cfile_of_program (for_unparser c_or_h
.asts
) outfile;
1944 show_or_not_diff c_or_h
.fpath
outfile;
1947 if !Flag.sgrep_mode2
then None
else Some
outfile)
1949 else (c_or_h
.fpath
, None
))
1952 let full_engine a b
=
1953 Common.profile_code
"full_engine"
1954 (fun () -> let res = full_engine2 a b
in (*Gc.print_stat stderr; *)res)
1956 let post_engine2 (cocci_infos,_) =
1958 (function ((language
,_),virt_rules
) ->
1959 Flag.defined_virtual_rules
:= virt_rules
;
1962 (function languages
->
1964 FinalScriptRuleCocciInfo
(r) ->
1965 (if r.language
= language
&& List.mem
r.language languages
1966 then failwith
("double finalizer found for "^
r.language
));
1967 initial_final_bigloop Final
1968 (fun (x
,_,_,y
) -> fun deps ->
1969 Ast_cocci.FinalScriptRule
(r.scr_rule_info
.rulename
,
1972 r.language
::languages
1976 !Iteration.initialization_stack
1979 Common.profile_code
"post_engine" (fun () -> post_engine2 a
)
1981 (*****************************************************************************)
1982 (* check duplicate from result of full_engine *)
1983 (*****************************************************************************)
1985 let check_duplicate_modif2 xs =
1986 (* opti: let groups = Common.groupBy (fun (a,resa) (b,resb) -> a =$= b) xs *)
1987 if !Flag_cocci.verbose_cocci
1988 then pr2
("Check duplication for " ^ i_to_s
(List.length
xs) ^
" files");
1990 let groups = Common.group_assoc_bykey_eff
xs in
1991 groups +> Common.map_filter
(fun (file, xs) ->
1993 | [] -> raise Impossible
1994 | [res] -> Some
(file, res)
1998 if not
(List.for_all
(fun res2
-> res2
=*= None
) xs)
2000 pr2
("different modification result for " ^
file);
2003 else Some
(file, None
)
2005 if not
(List.for_all
(fun res2
->
2009 let diff = Common.cmd_to_list
("diff -u -b -B "^
res^
" "^res2
)
2013 pr2
("different modification result for " ^
file);
2016 else Some
(file, Some
res)
2018 let check_duplicate_modif a
=
2019 Common.profile_code
"check_duplicate" (fun () -> check_duplicate_modif2 a
)