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 (if !Flag_cocci.use_saved_typedefs
then (Some saved_typedefs
) else None
)
51 (Some saved_macros
) file
in
54 let cprogram_of_file_cached file
=
55 let ((program2
,typedefs
,macros
), _stat
) = Parse_c.parse_cache file
in
56 if !Flag_cocci.ifdef_to_if
59 program2
+> Parse_c.with_program2
(fun asts
->
60 Cpp_ast_c.cpp_ifdef_statementize asts
63 else (program2
,typedefs
,macros
)
65 let cfile_of_program program2_with_ppmethod outf
=
66 Unparse_c.pp_program program2_with_ppmethod outf
68 (* for memoization, contains only one entry, the one for the SP *)
69 let _hparse = Hashtbl.create
101
70 let _h_ocaml_init = Hashtbl.create
101
71 let _hctl = Hashtbl.create
101
73 (* --------------------------------------------------------------------- *)
75 (* --------------------------------------------------------------------- *)
76 (* for a given pair (file,iso), only keep an instance for the most recent
77 virtual rules and virtual_env *)
79 let sp_of_file2 file iso
=
82 let (_
,xs
,_
,_
,_
,_
,_
) as res
= Parse_cocci.process file iso
false in
83 (* if there is already a compiled ML code, do nothing and use that *)
84 try let _ = Hashtbl.find
_h_ocaml_init (file
,iso
) in res
87 Hashtbl.add
_h_ocaml_init (file
,iso
) ();
88 match Prepare_ocamlcocci.prepare file xs
with
90 | Some ocaml_script_file
->
92 Prepare_ocamlcocci.load_file ocaml_script_file
;
93 (if not
!Common.save_tmp_files
94 then Prepare_ocamlcocci.clean_file ocaml_script_file
);
97 Hashtbl.add
_hparse (file
,iso
)
98 (!Flag.defined_virtual_rules
,!Flag.defined_virtual_env
,new_code);
101 let (rules
,env
,code
) = Hashtbl.find
_hparse (file
,iso
) in
102 if rules
= !Flag.defined_virtual_rules
&& env
= !Flag.defined_virtual_env
104 else (Hashtbl.remove
_hparse (file
,iso
); redo())
105 with Not_found
-> redo()
107 let sp_of_file file iso
=
108 Common.profile_code
"parse cocci" (fun () -> sp_of_file2 file iso
)
111 (* --------------------------------------------------------------------- *)
113 (* --------------------------------------------------------------------- *)
114 let print_flow flow
=
115 Ograph_extended.print_ograph_mutable flow
"/tmp/test.dot" true
118 let ast_to_flow_with_error_messages2 x
=
120 try Ast_to_flow.ast_to_control_flow x
121 with Ast_to_flow.Error x
->
122 Ast_to_flow.report_error x
;
125 flowopt +> do_option
(fun flow
->
126 (* This time even if there is a deadcode, we still have a
127 * flow graph, so I can try the transformation and hope the
128 * deadcode will not bother us.
130 try Ast_to_flow.deadcode_detection flow
131 with Ast_to_flow.Error
(Ast_to_flow.DeadCode x
) ->
132 Ast_to_flow.report_error
(Ast_to_flow.DeadCode x
);
135 let ast_to_flow_with_error_messages a
=
136 Common.profile_code
"flow" (fun () -> ast_to_flow_with_error_messages2 a
)
139 (* --------------------------------------------------------------------- *)
141 (* --------------------------------------------------------------------- *)
143 let ctls_of_ast2 ast
(ua
,fua
,fuas
) pos
=
145 (function ast
-> function (ua
,(fua
,(fuas
,pos
))) ->
149 else Asttoctl2.asttoctl ast
(ua
,fua
,fuas
) pos
)
150 (Asttomember.asttomember ast ua
))
151 ast
(List.combine ua
(List.combine fua
(List.combine fuas pos
)))
153 let ctls_of_ast ast ua
=
154 Common.profile_code
"asttoctl2" (fun () -> ctls_of_ast2 ast ua
)
156 (*****************************************************************************)
157 (* Some debugging functions *)
158 (*****************************************************************************)
162 let show_or_not_cfile2 cfile
=
163 if !Flag_cocci.show_c
then begin
164 Common.pr2_xxxxxxxxxxxxxxxxx
();
165 pr2
("processing C file: " ^ cfile
);
166 Common.pr2_xxxxxxxxxxxxxxxxx
();
167 Common.command2
("cat " ^ cfile
);
169 let show_or_not_cfile a
=
170 Common.profile_code
"show_xxx" (fun () -> show_or_not_cfile2 a
)
172 let show_or_not_cfiles cfiles
= List.iter
show_or_not_cfile cfiles
175 let show_or_not_cocci2 coccifile isofile
=
176 if !Flag_cocci.show_cocci
then begin
177 Common.pr2_xxxxxxxxxxxxxxxxx
();
178 pr2
("processing semantic patch file: " ^ coccifile
);
179 isofile
+> (fun s
-> pr2
("with isos from: " ^ s
));
180 Common.pr2_xxxxxxxxxxxxxxxxx
();
181 Common.command2
("cat " ^ coccifile
);
184 let show_or_not_cocci a b
=
185 Common.profile_code
"show_xxx" (fun () -> show_or_not_cocci2 a b
)
187 (* ---------------------------------------------------------------------- *)
190 let fix_sgrep_diffs l
=
192 List.filter
(function s
-> (s
=~
"^\\+\\+\\+") || not
(s
=~
"^\\+")) l in
193 let l = List.rev
l in
194 (* adjust second number for + code *)
195 let rec loop1 n
= function
198 if s
=~
"^-" && not
(s
=~
"^---")
199 then s
:: loop1 (n
+1) ss
202 (match Str.split
(Str.regexp
" ") s
with
205 match Str.split
(Str.regexp
",") pl
with
208 | _ -> failwith
"bad + line information" in
209 let n2 = int_of_string
n2 in
210 (Printf.sprintf
"%s %s %s,%d %s" bef min n1
(n2-n
)
211 (String.concat
" " aft
))
213 | _ -> failwith
"bad @@ information")
214 else s
:: loop1 n ss
in
215 let rec loop2 n
= function
222 (match Str.split
(Str.regexp
" ") s
with
225 match (Str.split
(Str.regexp
",") min
,
226 Str.split
(Str.regexp
",") pl
) with
227 ([_;m2
],[n1
;n2]) -> (m2
,n1
,n2)
228 | ([_],[n1
;n2]) -> ("1",n1
,n2)
229 | ([_;m2
],[n1
]) -> (m2
,n1
,"1")
230 | ([_],[n1
]) -> ("1",n1
,"1")
231 | _ -> failwith
"bad -/+ line information" in
233 int_of_string
(String.sub
n1 1 ((String.length
n1)-1)) in
234 let m2 = int_of_string
m2 in
235 let n2 = int_of_string
n2 in
236 (Printf.sprintf
"%s %s +%d,%d %s" bef min
(n1-n
) n2
237 (String.concat
" " aft
))
238 :: loop2 (n
+(m2-n2)) ss
239 | _ -> failwith
"bad @@ information")
240 else s
:: loop2 n ss
in
241 loop2 0 (List.rev
(loop1 0 l))
243 let normalize_path file
=
245 if String.get file
0 = '
/'
then file
else (Sys.getcwd
()) ^
"/" ^ file
in
246 let elements = Str.split_delim
(Str.regexp
"/") fullpath in
247 let rec loop prev
= function
248 [] -> String.concat
"/" (List.rev prev
)
249 | "." :: rest
-> loop prev rest
252 x
::xs
-> loop xs rest
253 | _ -> failwith
"bad path")
254 | x
::rest
-> loop (x
::prev
) rest
in
257 let generated_patches = Hashtbl.create
(100)
259 let show_or_not_diff2 cfile outfile
=
260 if !Flag_cocci.show_diff
then begin
261 match Common.fst
(Compare_c.compare_to_original cfile outfile
) with
262 Compare_c.Correct
-> () (* diff only in spacing, etc *)
264 (* may need --strip-trailing-cr under windows *)
268 match !Flag_parsing_c.diff_lines
with
269 | None
-> "diff -u -p " ^ cfile ^
" " ^ outfile
270 | Some n
-> "diff -U "^n^
" -p "^cfile^
" "^outfile
in
271 let res = Common.cmd_to_list
line in
275 match Str.split
(Str.regexp
"[ \t]+") l with
276 "---"::file
::date
-> "--- "^file
277 | "+++"::file
::date
-> "+++ "^file
281 match (!Flag.patch
,res) with
282 (* create something that looks like the output of patch *)
283 (Some prefix
,minus_file
::plus_file
::rest
) ->
285 let lp = String.length
prefix in
286 if String.get
prefix (lp-1) = '
/'
287 then String.sub
prefix 0 (lp-1)
289 let drop_prefix file
=
290 let file = normalize_path file in
291 if Str.string_match
(Str.regexp
prefix) file 0
293 let lp = String.length
prefix in
294 let lf = String.length
file in
296 then String.sub
file lp (lf - lp)
299 (Printf.sprintf
"prefix %s doesn't match file %s"
303 (Printf.sprintf
"prefix %s doesn't match file %s"
306 match List.rev
(Str.split
(Str.regexp
" ") line) with
307 new_file
::old_file
::cmdrev
->
308 let old_base_file = drop_prefix old_file
in
313 (("/tmp/nothing"^
old_base_file)
314 :: old_file
:: cmdrev
))
318 (("b"^
old_base_file)::("a"^
old_base_file)::
320 | _ -> failwith
"bad command" in
321 let (minus_line
,plus_line
) =
322 match (Str.split
(Str.regexp
"[ \t]") minus_file
,
323 Str.split
(Str.regexp
"[ \t]") plus_file
) with
324 ("---"::old_file
::old_rest
,"+++"::new_file
::new_rest
) ->
325 let old_base_file = drop_prefix old_file
in
327 then (minus_file
,"+++ /tmp/nothing"^
old_base_file)
330 ("---"::("a"^
old_base_file)::old_rest
),
332 ("+++"::("b"^
old_base_file)::new_rest
))
335 (Printf.sprintf
"bad diff header lines: %s %s"
336 (String.concat
":" l1
) (String.concat
":" l2
)) in
337 diff_line::minus_line
::plus_line
::rest
339 let xs = if !Flag.sgrep_mode2
then fix_sgrep_diffs xs else xs in
340 let cfile = normalize_path cfile in
342 try Hashtbl.find
generated_patches cfile
345 Hashtbl.add
generated_patches cfile cell;
347 if List.mem
xs !patches
351 patches := xs :: !patches;
355 let show_or_not_diff a b
=
356 Common.profile_code
"show_xxx" (fun () -> show_or_not_diff2 a b
)
359 (* the derived input *)
361 let show_or_not_ctl_tex2 astcocci ctls
=
362 if !Flag_cocci.show_ctl_tex
then begin
366 (function ((Asttoctl2.NONDECL ctl
| Asttoctl2.CODE ctl
),x
) ->
369 Ctltotex.totex
("/tmp/__cocci_ctl.tex") astcocci
ctls;
370 Common.command2
("cd /tmp; latex __cocci_ctl.tex; " ^
371 "dvips __cocci_ctl.dvi -o __cocci_ctl.ps;" ^
372 "gv __cocci_ctl.ps &");
374 let show_or_not_ctl_tex a b
=
375 Common.profile_code
"show_xxx" (fun () -> show_or_not_ctl_tex2 a b
)
378 let show_or_not_rule_name ast rulenb
=
379 if !Flag_cocci.show_ctl_text
or !Flag.show_trying
or
380 !Flag.show_transinfo
or !Flag_cocci.show_binding_in_out
385 Ast_cocci.CocciRule
(nm
, (deps
, drops
, exists
), x
, _, _) -> nm
386 | _ -> i_to_s rulenb
in
387 Common.pr_xxxxxxxxxxxxxxxxx
();
389 Common.pr_xxxxxxxxxxxxxxxxx
()
392 let show_or_not_scr_rule_name rulenb
=
393 if !Flag_cocci.show_ctl_text
or !Flag.show_trying
or
394 !Flag.show_transinfo
or !Flag_cocci.show_binding_in_out
397 let name = i_to_s rulenb
in
398 Common.pr_xxxxxxxxxxxxxxxxx
();
399 pr
("script rule " ^
name ^
" = ");
400 Common.pr_xxxxxxxxxxxxxxxxx
()
403 let show_or_not_ctl_text2 ctl ast rulenb
=
404 if !Flag_cocci.show_ctl_text
then begin
406 adjust_pp_with_indent
(fun () ->
407 Format.force_newline
();
408 Pretty_print_cocci.print_plus_flag
:= true;
409 Pretty_print_cocci.print_minus_flag
:= true;
410 Pretty_print_cocci.unparse ast
;
414 let ((Asttoctl2.CODE ctl
| Asttoctl2.NONDECL ctl
),_) = ctl
in
415 adjust_pp_with_indent
(fun () ->
416 Format.force_newline
();
417 Pretty_print_engine.pp_ctlcocci
418 !Flag_cocci.show_mcodekind_in_ctl
!Flag_cocci.inline_let_ctl ctl
;
422 let show_or_not_ctl_text a b c
=
423 Common.profile_code
"show_xxx" (fun () -> show_or_not_ctl_text2 a b c
)
427 (* running information *)
428 let get_celem celem
: string =
430 Ast_c.Definition
({Ast_c.f_name
= namefuncs
;},_) ->
431 Ast_c.str_of_name namefuncs
433 (Ast_c.DeclList
([{Ast_c.v_namei
= Some
(name, _);}, _], _)) ->
434 Ast_c.str_of_name
name
437 let show_or_not_celem2 prelude celem
=
440 | Ast_c.Definition
({Ast_c.f_name
= namefuncs
},_) ->
441 let funcs = Ast_c.str_of_name namefuncs
in
442 Flag.current_element
:= funcs;
443 (" function: ",funcs)
445 (Ast_c.DeclList
([{Ast_c.v_namei
= Some
(name,_)}, _], _)) ->
446 let s = Ast_c.str_of_name
name in
447 Flag.current_element
:= s;
450 Flag.current_element
:= "something_else";
451 (" ","something else");
453 if !Flag.show_trying
then pr2
(prelude ^ tag ^ trying
)
455 let show_or_not_celem a b
=
456 Common.profile_code
"show_xxx" (fun () -> show_or_not_celem2 a b
)
459 let show_or_not_trans_info2 trans_info
=
460 (* drop witness tree indices for printing *)
462 List.map
(function (index
,trans_info) -> trans_info) trans_info in
463 if !Flag.show_transinfo
then begin
464 if null
trans_info then pr2
"transformation info is empty"
466 pr2
"transformation info returned:";
468 List.sort
(function (i1
,_,_) -> function (i2
,_,_) -> compare i1 i2
)
472 trans_info +> List.iter
(fun (i
, subst
, re
) ->
473 pr2
("transform state: " ^
(Common.i_to_s i
));
475 adjust_pp_with_indent_and_header
"with rule_elem: " (fun () ->
476 Pretty_print_cocci.print_plus_flag
:= true;
477 Pretty_print_cocci.print_minus_flag
:= true;
478 Pretty_print_cocci.rule_elem
"" re
;
480 adjust_pp_with_indent_and_header
"with binding: " (fun () ->
481 Pretty_print_engine.pp_binding subst
;
488 let show_or_not_trans_info a
=
489 Common.profile_code
"show_xxx" (fun () -> show_or_not_trans_info2 a
)
493 let show_or_not_binding2 s binding
=
494 if !Flag_cocci.show_binding_in_out
then begin
495 adjust_pp_with_indent_and_header
("binding " ^
s ^
" = ") (fun () ->
496 Pretty_print_engine.pp_binding binding
499 let show_or_not_binding a b
=
500 Common.profile_code
"show_xxx" (fun () -> show_or_not_binding2 a b
)
504 (*****************************************************************************)
505 (* Some helper functions *)
506 (*****************************************************************************)
508 let worth_trying cfiles tokens
=
509 (* drop the following line for a list of list by rules. since we don't
510 allow multiple minirules, all the tokens within a rule should be in
511 a single CFG entity *)
512 match (!Flag_cocci.windows
,tokens
) with
513 (true,_) | (_,None
) -> true
515 (* could also modify the code in get_constants.ml *)
516 let tokens = tokens +> List.map
(fun s ->
518 | _ when s =~
"^[A-Za-z_][A-Za-z_0-9]*$" ->
521 | _ when s =~
"^[A-Za-z_]" ->
524 | _ when s =~
".*[A-Za-z_]$" ->
529 let com = sprintf
"egrep -q '(%s)' %s" (join
"|" tokens) (join
" " cfiles
)
531 (match Sys.command
com with
532 | 0 (* success *) -> true
535 then Printf.printf
"grep failed: %s\n" com);
536 false (* no match, so not worth trying *))
538 let check_macro_in_sp_and_adjust = function
541 tokens +> List.iter
(fun s ->
542 if Hashtbl.mem
!Parse_c._defs
s
544 if !Flag_cocci.verbose_cocci
then begin
545 pr2
"warning: macro in semantic patch was in macro definitions";
546 pr2
("disabling macro expansion for " ^
s);
548 Hashtbl.remove
!Parse_c._defs
s
552 let contain_loop gopt
=
555 g#nodes#tolist
+> List.exists
(fun (xi
, node
) ->
556 Control_flow_c.extract_is_loop node
558 | None
-> true (* means nothing, if no g then will not model check *)
562 let sp_contain_typed_metavar_z toplevel_list_list
=
563 let bind x y
= x
or y
in
564 let option_default = false in
565 let mcode _ _ = option_default in
566 let donothing r k e
= k e
in
568 let expression r k e
=
569 match Ast_cocci.unwrap e
with
570 | Ast_cocci.MetaExpr
(_,_,_,Some t
,_,_) -> true
571 | Ast_cocci.MetaExpr
(_,_,_,_,Ast_cocci.LocalID
,_) -> true
576 Visitor_ast.combiner bind option_default
577 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
578 donothing donothing donothing donothing donothing
579 donothing expression donothing donothing donothing donothing donothing
580 donothing donothing donothing donothing donothing
582 toplevel_list_list
+>
584 (function (nm
,_,rule
) ->
585 (List.exists
combiner.Visitor_ast.combiner_top_level rule
))
587 let sp_contain_typed_metavar rules
=
588 sp_contain_typed_metavar_z
592 Ast_cocci.CocciRule
(a
,b
,c
,d
,_) -> (a
,b
,c
)
593 | _ -> failwith
"error in filter")
597 Ast_cocci.CocciRule
(a
,b
,c
,d
,Ast_cocci.Normal
) -> true
603 (* finding among the #include the one that we need to parse
604 * because they may contain useful type definition or because
605 * we may have to modify them
607 * For the moment we base in part our heuristic on the name of the file, e.g.
608 * serio.c is related we think to #include <linux/serio.h>
610 let include_table = Hashtbl.create
(100)
612 let interpret_include_path relpath
=
613 let maxdepth = List.length relpath
in
614 let unique_file_exists dir f
=
616 Printf.sprintf
"find %s -maxdepth %d -mindepth %d -path \"*/%s\""
617 dir
maxdepth maxdepth f
in
618 match Common.cmd_to_list
cmd with
621 let native_file_exists dir f
=
622 let f = Filename.concat dir
f in
626 let rec search_include_path exists searchlist relpath
=
627 match searchlist
with
630 (match exists hd relpath
with
632 | None
-> search_include_path exists tail relpath
) in
633 let rec search_path exists searchlist
= function
635 let res = Common.concat
"/" relpath
in
636 Hashtbl.add
include_table (searchlist
,relpath
) res;
638 | (hd
::tail
) as relpath1
->
639 let relpath1 = Common.concat
"/" relpath1 in
640 (match search_include_path exists searchlist
relpath1 with
641 None
-> search_path unique_file_exists searchlist tail
643 Hashtbl.add
include_table (searchlist
,relpath
) f;
646 match !Flag_cocci.include_path
with
649 try Some
(Hashtbl.find
include_table (searchlist,relpath
))
651 search_path native_file_exists searchlist relpath
653 let (includes_to_parse
:
654 (Common.filename
* Parse_c.extended_program2
) list
->
655 Flag_cocci.include_options
-> 'a
) = fun xs choose_includes
->
656 match choose_includes
with
657 Flag_cocci.I_UNSPECIFIED
-> failwith
"not possible"
658 | Flag_cocci.I_NO_INCLUDES
-> []
662 [Flag_cocci.I_ALL_INCLUDES
; Flag_cocci.I_REALLY_ALL_INCLUDES
] in
663 let xs = List.map
(function (file,(cs
,_,_)) -> (file,cs
)) xs in
664 xs +> List.map
(fun (file, cs
) ->
665 let dir = Common.dirname
file in
667 cs
+> Common.map_filter
(fun (c
,_info_item
) ->
671 {Ast_c.i_include
= ((x
,ii
)); i_rel_pos
= info_h_pos
;}) ->
674 let relpath = Common.join
"/" xs in
675 let f = Filename.concat
dir relpath in
676 if (Sys.file_exists
f) then
679 if !Flag_cocci.relax_include_path
680 (* for our tests, all the files are flat in the current dir *)
682 let attempt2 = Filename.concat
dir (Common.last
xs) in
683 if not
(Sys.file_exists
attempt2) && all_includes
685 interpret_include_path xs
688 if all_includes then interpret_include_path xs
691 | Ast_c.NonLocal
xs ->
693 Common.fileprefix
(Common.last
xs) =$
= Common.fileprefix
file
695 interpret_include_path xs
697 | Ast_c.Weird
_ -> None
701 +> (fun x
-> (List.rev
(Common.uniq
(List.rev x
)))) (*uniq keeps last*)
703 let rec interpret_dependencies local global
= function
704 Ast_cocci.Dep
s -> List.mem
s local
705 | Ast_cocci.AntiDep
s ->
706 (if !Flag_ctl.steps
!= None
707 then failwith
"steps and ! dependency incompatible");
708 not
(List.mem
s local
)
709 | Ast_cocci.EverDep
s -> List.mem
s global
710 | Ast_cocci.NeverDep
s ->
711 (if !Flag_ctl.steps
!= None
712 then failwith
"steps and ! dependency incompatible");
713 not
(List.mem
s global
)
714 | Ast_cocci.AndDep
(s1
,s2
) ->
715 (interpret_dependencies local global s1
) &&
716 (interpret_dependencies local global s2
)
717 | Ast_cocci.OrDep
(s1
,s2
) ->
718 (interpret_dependencies local global s1
) or
719 (interpret_dependencies local global s2
)
720 | Ast_cocci.NoDep
-> true
721 | Ast_cocci.FailDep
-> false
723 let rec print_dependencies str local global dep
=
724 if !Flag_cocci.show_dependencies
729 let rec loop = function
730 Ast_cocci.Dep
s | Ast_cocci.AntiDep
s ->
731 if not
(List.mem
s !seen)
735 then pr2
(s^
" satisfied")
736 else pr2
(s^
" not satisfied");
739 | Ast_cocci.EverDep
s | Ast_cocci.NeverDep
s ->
740 if not
(List.mem
s !seen)
744 then pr2
(s^
" satisfied")
745 else pr2
(s^
" not satisfied");
748 | Ast_cocci.AndDep
(s1
,s2
) ->
751 | Ast_cocci.OrDep
(s1
,s2
) ->
754 | Ast_cocci.NoDep
-> ()
755 | Ast_cocci.FailDep
-> pr2
"False not satisfied" in
759 (* --------------------------------------------------------------------- *)
760 (* #include relative position in the file *)
761 (* --------------------------------------------------------------------- *)
763 (* compute the set of new prefixes
765 * "a/b/x"; (* in fact it is now a list of string so ["a";"b";"x"] *)
769 * it would give
for the first element
770 * ""; "a"; "a/b"; "a/b/x"
774 * update
: if the
include is inside a ifdef a put nothing
. cf
-test incl
.
775 * this is because we dont want code added inside ifdef
.
778 let compute_new_prefixes xs =
779 xs +> Common.map_withenv
(fun already
xs ->
780 let subdirs_prefixes = Common.inits
xs in
781 let new_first = subdirs_prefixes +> List.filter
(fun x
->
782 not
(List.mem x already
)
791 (* does via side effect on the ref in the Include in Ast_c *)
792 let rec update_include_rel_pos cs
=
793 let only_include = cs
+> Common.map_filter
(fun c
->
795 | Ast_c.CppTop
(Ast_c.Include
{Ast_c.i_include
= ((x
,_));
797 i_is_in_ifdef
= inifdef
}) ->
799 | Ast_c.Weird
_ -> None
808 let (locals
, nonlocals
) =
809 only_include +> Common.partition_either
(fun (c
, aref
) ->
811 | Ast_c.Local x
-> Left
(x
, aref
)
812 | Ast_c.NonLocal x
-> Right
(x
, aref
)
813 | Ast_c.Weird x
-> raise Impossible
816 update_rel_pos_bis locals
;
817 update_rel_pos_bis nonlocals
;
819 and update_rel_pos_bis
xs =
820 let xs'
= List.map fst
xs in
821 let the_first = compute_new_prefixes xs'
in
822 let the_last = List.rev
(compute_new_prefixes (List.rev
xs'
)) in
823 let merged = Common.zip
xs (Common.zip
the_first the_last) in
824 merged +> List.iter
(fun ((x
, aref
), (the_first, the_last)) ->
827 Ast_c.first_of
= the_first;
828 Ast_c.last_of
= the_last;
833 (*****************************************************************************)
834 (* All the information needed around the C elements and Cocci rules *)
835 (*****************************************************************************)
837 type toplevel_c_info
= {
838 ast_c
: Ast_c.toplevel
; (* contain refs so can be modified *)
839 tokens_c
: Parser_c.token list
;
842 flow
: Control_flow_c.cflow
option; (* it's the "fixed" flow *)
845 env_typing_before
: TAC.environment
;
846 env_typing_after
: TAC.environment
;
848 was_modified
: bool ref;
850 all_typedefs
: (string, Lexer_parser.identkind
) Common.scoped_h_env
;
851 all_macros
: (string, Cpp_token_c.define_def
) Hashtbl.t
;
858 dependencies
: Ast_cocci.dependency
;
859 used_after
: Ast_cocci.meta_name list
;
861 was_matched
: bool ref;
864 type toplevel_cocci_info_script_rule
= {
867 (Ast_cocci.script_meta_name
* Ast_cocci.meta_name
*
868 Ast_cocci.metavar
) list
*
869 Ast_cocci.meta_name list
(*fresh vars*) *
873 scr_rule_info
: rule_info
;
876 type toplevel_cocci_info_cocci_rule
= {
877 ctl
: Asttoctl2.top_formula
* (CCI.pred list list
);
878 metavars
: Ast_cocci.metavar list
;
879 ast_rule
: Ast_cocci.rule
;
880 isexp
: bool; (* true if + code is an exp, only for Flag.make_hrule *)
882 (* There are also some hardcoded rule names in parse_cocci.ml:
883 * let reserved_names = ["all";"optional_storage";"optional_qualifier"]
885 dropped_isos
: string list
;
886 free_vars
: Ast_cocci.meta_name list
;
887 negated_pos_vars
: Ast_cocci.meta_name list
;
888 positions
: Ast_cocci.meta_name list
;
890 ruletype
: Ast_cocci.ruletype
;
892 rule_info
: rule_info
;
895 type toplevel_cocci_info
=
896 ScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
897 | InitialScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
898 | FinalScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
899 | CocciRuleCocciInfo
of toplevel_cocci_info_cocci_rule
901 type cocci_info
= toplevel_cocci_info list
* string list
option (* tokens *)
903 type kind_file
= Header
| Source
907 was_modified_once
: bool ref;
908 asts
: toplevel_c_info list
;
913 let g_contain_typedmetavar = ref false
916 let last_env_toplevel_c_info xs =
917 (Common.last
xs).env_typing_after
919 let concat_headers_and_c (ccs
: file_info list
)
920 : (toplevel_c_info
* string) list
=
921 (List.concat
(ccs
+> List.map
(fun x
->
922 x
.asts
+> List.map
(fun x'
->
925 let for_unparser xs =
926 xs +> List.map
(fun x
->
927 (x
.ast_c
, (x
.fullstring
, x
.tokens_c
)), Unparse_c.PPviastr
930 let gen_pdf_graph () =
931 (Ctl_engine.get_graph_files
()) +> List.iter
(fun outfile
->
932 Printf.printf
"Generation of %s%!" outfile
;
933 let filename_stack = Ctl_engine.get_graph_comp_files outfile
in
934 List.iter
(fun filename
->
935 ignore
(Unix.system
("dot " ^ filename ^
" -Tpdf -o " ^ filename ^
".pdf;"))
937 let (head
,tail
) = (List.hd
filename_stack, List.tl
filename_stack) in
938 ignore
(Unix.system
("cp " ^ head ^
".pdf " ^ outfile ^
".pdf;"));
939 tail
+> List.iter
(fun filename
->
940 ignore
(Unix.system
("mv " ^ outfile ^
".pdf /tmp/tmp.pdf;"));
941 ignore
(Unix.system
("pdftk " ^ filename ^
".pdf /tmp/tmp.pdf cat output " ^ outfile ^
".pdf"));
943 ignore
(Unix.system
("rm /tmp/tmp.pdf;"));
944 List.iter
(fun filename
->
945 ignore
(Unix.system
("rm " ^ filename ^
" " ^ filename ^
".pdf;"))
947 Printf.printf
" - Done\n")
949 let local_python_code =
950 "from coccinelle import *\n"
953 "import coccinelle\n"^
955 "import coccilib.org\n"^
956 "import coccilib.report\n" ^
960 let make_init lang code rule_info
=
963 scr_ast_rule
= (lang
, mv, [], code
);
965 script_code
= (if lang
= "python" then python_code else "") ^code
;
966 scr_rule_info
= rule_info
;
969 (* --------------------------------------------------------------------- *)
970 let prepare_cocci ctls free_var_lists negated_pos_lists
971 (ua
,fua
,fuas
) positions_list metavars astcocci
=
973 let gathered = Common.index_list_1
974 (zip
(zip
(zip
(zip
(zip
(zip
(zip
(zip
ctls metavars
) astcocci
)
976 negated_pos_lists
) ua
) fua
) fuas
) positions_list
)
979 (fun (((((((((ctl_toplevel_list
,metavars
),ast
),free_var_list
),
980 negated_pos_list
),ua
),fua
),fuas
),positions_list
),rulenb
) ->
982 let build_rule_info rulename deps
=
983 {rulename
= rulename
;
985 used_after
= (List.hd ua
) @ (List.hd fua
);
987 was_matched
= ref false;} in
989 let is_script_rule r
=
991 Ast_cocci.ScriptRule
_
992 | Ast_cocci.InitialScriptRule
_ | Ast_cocci.FinalScriptRule
_ -> true
995 if not
(List.length ctl_toplevel_list
=|= 1) && not
(is_script_rule ast
)
996 then failwith
"not handling multiple minirules";
999 Ast_cocci.ScriptRule
(name,lang
,deps
,mv,script_vars
,code
) ->
1002 scr_ast_rule
= (lang
, mv, script_vars
, code
);
1005 scr_rule_info
= build_rule_info name deps
;
1007 in ScriptRuleCocciInfo
r
1008 | Ast_cocci.InitialScriptRule
(name,lang
,deps
,code
) ->
1009 let r = make_init lang code
(build_rule_info name deps
) in
1010 InitialScriptRuleCocciInfo
r
1011 | Ast_cocci.FinalScriptRule
(name,lang
,deps
,code
) ->
1015 scr_ast_rule
= (lang
, mv, [], code
);
1018 scr_rule_info
= build_rule_info name deps
;
1020 in FinalScriptRuleCocciInfo
r
1021 | Ast_cocci.CocciRule
1022 (rulename
,(dependencies
,dropped_isos
,z
),restast
,isexp
,ruletype
) ->
1023 CocciRuleCocciInfo
(
1025 ctl
= List.hd ctl_toplevel_list
;
1026 metavars
= metavars
;
1028 isexp
= List.hd isexp
;
1029 dropped_isos
= dropped_isos
;
1030 free_vars
= List.hd free_var_list
;
1031 negated_pos_vars
= List.hd negated_pos_list
;
1032 positions
= List.hd positions_list
;
1033 ruletype
= ruletype
;
1034 rule_info
= build_rule_info rulename dependencies
;
1038 (* --------------------------------------------------------------------- *)
1040 let build_info_program (cprogram
,typedefs
,macros
) env
=
1042 let (cs
, parseinfos
) =
1043 Common.unzip cprogram
in
1046 parseinfos
+> List.map
(fun (s,toks
) -> toks
) +> List.flatten
in
1048 (* I use cs' but really annotate_xxx work by doing side effects on cs *)
1050 Comment_annotater_c.annotate_program
alltoks cs in
1053 Type_annoter_c.annotate_program env
(*!g_contain_typedmetavar*) cs'
1056 zip
cs_with_envs parseinfos
+> List.map
(fun ((c
, (enva
,envb
)), parseinfo
)->
1057 let (fullstr
, tokens) = parseinfo
in
1060 ast_to_flow_with_error_messages c
+>
1061 Common.map_option
(fun flow ->
1062 let flow = Ast_to_flow.annotate_loop_nodes
flow in
1064 (* remove the fake nodes for julia *)
1065 let fixed_flow = CCI.fix_flow_ctl
flow in
1067 if !Flag_cocci.show_flow
then print_flow fixed_flow;
1068 if !Flag_cocci.show_before_fixed_flow
then print_flow flow;
1075 ast_c
= c
; (* contain refs so can be modified *)
1077 fullstring
= fullstr
;
1081 contain_loop = contain_loop flow;
1083 env_typing_before
= enva
;
1084 env_typing_after
= envb
;
1086 was_modified
= ref false;
1088 all_typedefs
= typedefs
;
1089 all_macros
= macros
;
1095 (* Optimisation. Try not unparse/reparse the whole file when have modifs *)
1096 let rebuild_info_program cs file isexp
=
1097 cs +> List.map
(fun c
->
1098 if !(c
.was_modified
)
1100 let file = Common.new_temp_file
"cocci_small_output" ".c" in
1102 [(c
.ast_c
, (c
.fullstring
, c
.tokens_c
)), Unparse_c.PPnormal
]
1105 (* Common.command2 ("cat " ^ file); *)
1106 let cprogram = cprogram_of_file c
.all_typedefs c
.all_macros
file in
1107 let xs = build_info_program cprogram c
.env_typing_before
in
1109 (* TODO: assert env has not changed,
1110 * if yes then must also reparse what follows even if not modified.
1111 * Do that only if contain_typedmetavar of course, so good opti.
1113 (* Common.list_init xs *) (* get rid of the FinalDef *)
1119 let rebuild_info_c_and_headers ccs isexp
=
1120 ccs
+> List.iter
(fun c_or_h
->
1121 if c_or_h
.asts
+> List.exists
(fun c
-> !(c
.was_modified
))
1122 then c_or_h
.was_modified_once
:= true;
1124 ccs
+> List.map
(fun c_or_h
->
1127 rebuild_info_program c_or_h
.asts c_or_h
.full_fname isexp
}
1130 let rec prepare_h seen env hpath choose_includes
: file_info list
=
1131 if not
(Common.lfile_exists hpath
)
1134 pr2_once
("TYPE: header " ^ hpath ^
" not found");
1139 let h_cs = cprogram_of_file_cached hpath
in
1140 let local_includes =
1141 if choose_includes
=*= Flag_cocci.I_REALLY_ALL_INCLUDES
1144 (function x
-> not
(List.mem x
!seen))
1145 (includes_to_parse
[(hpath
,h_cs)] choose_includes
)
1147 seen := local_includes @ !seen;
1150 (List.map
(function x
-> prepare_h seen env x choose_includes
)
1152 let info_h_cs = build_info_program h_cs !env
in
1156 else last_env_toplevel_c_info info_h_cs;
1159 fname
= Common.basename hpath
;
1162 was_modified_once
= ref false;
1168 let prepare_c files choose_includes
: file_info list
=
1169 let cprograms = List.map
cprogram_of_file_cached files
in
1170 let includes = includes_to_parse
(zip files
cprograms) choose_includes
in
1171 let seen = ref includes in
1173 (* todo?: may not be good to first have all the headers and then all the c *)
1174 let env = ref !TAC.initial_env
in
1178 List.map
(function hpath
-> prepare_h seen env hpath choose_includes
) +>
1182 (zip files
cprograms) +>
1184 (function (file, cprogram) ->
1185 (* todo?: don't update env ? *)
1186 let cs = build_info_program cprogram !env in
1187 (* we do that only for the c, not for the h *)
1188 ignore
(update_include_rel_pos (cs +> List.map
(fun x
-> x
.ast_c
)));
1190 fname
= Common.basename
file;
1193 was_modified_once
= ref false;
1200 (*****************************************************************************)
1201 (* Manage environments as they are being built up *)
1202 (*****************************************************************************)
1204 let init_env _ = Hashtbl.create
101
1206 let update_env env v i
= Hashtbl.replace
env v i
; env
1208 (* know that there are no conflicts *)
1209 let safe_update_env env v i
= Hashtbl.add
env v i
; env
1212 List.sort compare
(Hashtbl.fold
(fun k v rest
-> (k
,v
) :: rest
) env [])
1214 (*****************************************************************************)
1215 (* Processing the ctls and toplevel C elements *)
1216 (*****************************************************************************)
1218 (* The main algorithm =~
1219 * The algorithm is roughly:
1220 * for_all ctl rules in SP
1221 * for_all minirule in rule (no more)
1222 * for_all binding (computed during previous phase)
1223 * for_all C elements
1224 * match control flow of function vs minirule
1225 * with the binding and update the set of possible
1226 * bindings, and returned the possibly modified function.
1227 * pretty print modified C elements and reparse it.
1230 * On ne prends que les newbinding ou returned_any_state est vrai.
1231 * Si ca ne donne rien, on prends ce qu'il y avait au depart.
1232 * Mais au nouveau depart de quoi ?
1233 * - si ca donne rien apres avoir traité toutes les fonctions avec ce binding ?
1234 * - ou alors si ca donne rien, apres avoir traité toutes les fonctions
1235 * avec tous les bindings du round d'avant ?
1237 * Julia pense qu'il faut prendre la premiere solution.
1238 * Example: on a deux environnements candidats, E1 et E2 apres avoir traité
1239 * la regle ctl 1. On arrive sur la regle ctl 2.
1240 * E1 ne donne rien pour la regle 2, on garde quand meme E1 pour la regle 3.
1241 * E2 donne un match a un endroit et rend E2' alors on utilise ca pour
1244 * I have not to look at used_after_list to decide to restart from
1245 * scratch. I just need to look if the binding list is empty.
1246 * Indeed, let's suppose that a SP have 3 regions/rules. If we
1247 * don't find a match for the first region, then if this first
1248 * region does not bind metavariable used after, that is if
1249 * used_after_list is empty, then mysat(), even if does not find a
1250 * match, will return a Left, with an empty transformation_info,
1251 * and so current_binding will grow. On the contrary if the first
1252 * region must bind some metavariables used after, and that we
1253 * dont find any such region, then mysat() will returns lots of
1254 * Right, and current_binding will not grow, and so we will have
1255 * an empty list of binding, and we will catch such a case.
1257 * opti: julia says that because the binding is
1258 * determined by the used_after_list, the items in the list
1259 * are kind of sorted, so could optimise the insert_set operations.
1263 (* r(ule), c(element in C code), e(nvironment) *)
1265 let merge_env new_e old_e
=
1267 (function (e
,rules
) ->
1268 let _ = update_env old_e e rules
in ()) new_e
;
1271 let contains_binding e
(_,(r,m
),_) =
1273 let _ = List.find
(function ((re
, rm
), _) -> r =*= re
&& m
=$
= rm
) e
in
1275 with Not_found
-> false
1279 let python_application mv ve script_vars
r =
1283 ((Some x
,None
),y
,z
) -> (x
,y
,z
)
1286 (Printf.sprintf
"unexpected ast metavar in rule %s"
1287 r.scr_rule_info
.rulename
))
1290 Pycocci.build_classes
(List.map
(function (x
,y
) -> x
) ve
);
1291 Pycocci.construct_variables
mv ve
;
1292 Pycocci.construct_script_variables script_vars
;
1293 let _ = Pycocci.pyrun_simplestring
(local_python_code ^
r.script_code
) in
1296 else if !Pycocci.inc_match
1297 then Some
(Pycocci.retrieve_script_variables script_vars
)
1299 with Pycocci.Pycocciexception
->
1300 (pr2
("Failure in " ^
r.scr_rule_info
.rulename
);
1301 raise
Pycocci.Pycocciexception
)
1303 let ocaml_application mv ve script_vars
r =
1306 Run_ocamlcocci.run
mv ve script_vars
1307 r.scr_rule_info
.rulename
r.script_code
in
1310 else if !Coccilib.inc_match
1311 then Some
script_vals
1313 with e
-> (pr2
("Failure in " ^
r.scr_rule_info
.rulename
); raise e
)
1315 (* returns Left in case of dependency failure, Right otherwise *)
1316 let apply_script_rule r cache newes e rules_that_have_matched
1317 rules_that_have_ever_matched script_application
=
1318 Common.profile_code
r.language
(fun () ->
1319 show_or_not_scr_rule_name r.scr_rule_info
.ruleid
;
1320 if not
(interpret_dependencies rules_that_have_matched
1321 !rules_that_have_ever_matched
r.scr_rule_info
.dependencies
)
1324 print_dependencies "dependencies for script not satisfied:"
1325 rules_that_have_matched
1326 !rules_that_have_ever_matched
r.scr_rule_info
.dependencies
;
1327 show_or_not_binding "in environment" e
;
1328 (cache
, safe_update_env newes e rules_that_have_matched
)
1332 let (_, mv, script_vars
, _) = r.scr_ast_rule
in
1334 (List.map
(function (n
,v
) -> (("virtual",n
),Ast_c.MetaIdVal
(v
,[])))
1335 !Flag.defined_virtual_env
) @ e
in
1336 let not_bound x
= not
(contains_binding ve x
) in
1337 (match List.filter
not_bound mv with
1339 let relevant_bindings =
1341 (function ((re
,rm
),_) ->
1342 List.exists
(function (_,(r,m
),_) -> r =*= re
&& m
=$
= rm
) mv)
1345 match List.assoc
relevant_bindings cache
with
1346 None
-> (cache
,newes
)
1347 | Some
script_vals ->
1349 "dependencies for script satisfied, but cached:"
1350 rules_that_have_matched
1351 !rules_that_have_ever_matched
1352 r.scr_rule_info
.dependencies
;
1353 show_or_not_binding "in" e
;
1354 (* env might be bigger than what was cached against, so have to
1355 merge with newes anyway *)
1356 let new_e = (List.combine script_vars
script_vals) @ e
in
1360 (fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1361 (cache
,update_env newes
new_e rules_that_have_matched
)
1364 print_dependencies "dependencies for script satisfied:"
1365 rules_that_have_matched
1366 !rules_that_have_ever_matched
1367 r.scr_rule_info
.dependencies
;
1368 show_or_not_binding "in" e
;
1369 match script_application
mv ve script_vars
r with
1371 (* failure means we should drop e, no new bindings *)
1372 (((relevant_bindings,None
) :: cache
), newes
)
1373 | Some
script_vals ->
1375 List.map
(function x
-> Ast_c.MetaIdVal
(x
,[]))
1377 let new_e = (List.combine script_vars
script_vals) @ e
in
1381 (fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1382 r.scr_rule_info
.was_matched
:= true;
1383 (((relevant_bindings,Some
script_vals) :: cache
),
1384 update_env newes
new_e
1385 (r.scr_rule_info
.rulename
:: rules_that_have_matched
))
1388 (if !Flag_cocci.show_dependencies
1390 let m2c (_,(r,x
),_) = r^
"."^x
in
1391 pr2
(Printf.sprintf
"script not applied: %s not bound"
1392 (String.concat
", " (List.map
m2c unbound
))));
1395 List.filter
(fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1396 (cache
, update_env newes
e rules_that_have_matched
))
1399 let rec apply_cocci_rule r rules_that_have_ever_matched es
1400 (ccs
:file_info list
ref) =
1401 Common.profile_code
r.rule_info
.rulename
(fun () ->
1402 show_or_not_rule_name r.ast_rule
r.rule_info
.ruleid
;
1403 show_or_not_ctl_text r.ctl
r.ast_rule
r.rule_info
.ruleid
;
1405 let reorganized_env =
1406 reassociate_positions
r.free_vars
r.negated_pos_vars
!es
in
1408 (* looping over the environments *)
1409 let (_,newes
(* envs for next round/rule *)) =
1411 (function (cache
,newes
) ->
1412 function ((e,rules_that_have_matched
),relevant_bindings) ->
1413 if not
(interpret_dependencies rules_that_have_matched
1414 !rules_that_have_ever_matched
1415 r.rule_info
.dependencies
)
1419 ("dependencies for rule "^
r.rule_info
.rulename^
1421 rules_that_have_matched
1422 !rules_that_have_ever_matched
r.rule_info
.dependencies
;
1423 show_or_not_binding "in environment" e;
1428 (fun (s,v
) -> List.mem
s r.rule_info
.used_after
))
1429 rules_that_have_matched
)
1433 try List.assoc
relevant_bindings cache
1437 ("dependencies for rule "^
r.rule_info
.rulename^
1439 rules_that_have_matched
1440 !rules_that_have_ever_matched
1441 r.rule_info
.dependencies
;
1442 show_or_not_binding "in" e;
1443 show_or_not_binding "relevant in" relevant_bindings;
1445 (* applying the rule *)
1446 (match r.ruletype
with
1448 (* looping over the functions and toplevel elements in
1451 (concat_headers_and_c !ccs
+>
1452 List.fold_left
(fun children_e
(c
,f) ->
1455 (* does also some side effects on c and r *)
1457 process_a_ctl_a_env_a_toplevel
r
1458 relevant_bindings c
f in
1459 match processed with
1460 | None
-> children_e
1461 | Some newbindings
->
1464 (fun children_e newbinding
->
1465 if List.mem newbinding children_e
1467 else newbinding
:: children_e
)
1471 | Ast_cocci.Generated
->
1472 process_a_generated_a_env_a_toplevel
r
1473 relevant_bindings !ccs
;
1476 let old_bindings_to_keep =
1480 (fun (s,v
) -> List.mem
s r.rule_info
.used_after
)) in
1482 if null
new_bindings
1485 (*use the old bindings, specialized to the used_after_list*)
1486 if !Flag_ctl.partial_match
1489 "Empty list of bindings, I will restart from old env\n";
1490 [(old_bindings_to_keep,rules_that_have_matched
)]
1493 (* combine the new bindings with the old ones, and
1494 specialize to the used_after_list *)
1495 let old_variables = List.map fst
old_bindings_to_keep in
1496 (* have to explicitly discard the inherited variables
1497 because we want the inherited value of the positions
1498 variables not the extended one created by
1499 reassociate_positions. want to reassociate freshly
1500 according to the free variables of each rule. *)
1501 let new_bindings_to_add =
1507 (* see comment before combine_pos *)
1508 (s,Ast_c.MetaPosValList
[]) -> false
1510 List.mem
s r.rule_info
.used_after
&&
1511 not
(List.mem
s old_variables)))) in
1513 (function new_binding_to_add
->
1516 old_bindings_to_keep new_binding_to_add
),
1517 r.rule_info
.rulename
::rules_that_have_matched
))
1518 new_bindings_to_add in
1519 ((relevant_bindings,new_bindings)::cache
,
1520 Common.profile_code
"merge_env" (function _ ->
1521 merge_env new_e newes
)))
1522 ([],init_env()) reorganized_env in (* end iter es *)
1523 if !(r.rule_info
.was_matched
)
1524 then Common.push2
r.rule_info
.rulename rules_that_have_ever_matched
;
1526 es
:= end_env newes
;
1528 (* apply the tagged modifs and reparse *)
1529 if not
!Flag.sgrep_mode2
1530 then ccs
:= rebuild_info_c_and_headers !ccs
r.isexp
)
1532 and reassociate_positions free_vars negated_pos_vars envs
=
1533 (* issues: isolate the bindings that are relevant to a given rule.
1534 separate out the position variables
1535 associate all of the position variables for a given set of relevant
1536 normal variable bindings with each set of relevant normal variable
1537 bindings. Goal: if eg if@p (E) matches in two places, then both inherited
1538 occurrences of E should see both bindings of p, not just its own.
1539 Otherwise, a position constraint for something that matches in two
1540 places will never be useful, because the position can always be
1541 different from the other one. *)
1545 List.filter
(function (x
,_) -> List.mem x free_vars
) e)
1547 let splitted_relevant =
1548 (* separate the relevant variables into the non-position ones and the
1553 (function (non_pos
,pos
) ->
1554 function (v
,_) as x
->
1555 if List.mem v negated_pos_vars
1556 then (non_pos
,x
::pos
)
1557 else (x
::non_pos
,pos
))
1560 let splitted_relevant =
1562 (function (non_pos
,pos
) ->
1563 (List.sort compare non_pos
,List.sort compare pos
))
1564 splitted_relevant in
1567 (function non_pos
->
1569 if List.mem np non_pos
then non_pos
else np
::non_pos
)
1570 [] splitted_relevant in
1571 let extended_relevant =
1572 (* extend the position variables with the values found at other identical
1573 variable bindings *)
1575 (function non_pos
->
1578 (function (other_non_pos
,other_pos
) ->
1579 (* do we want equal? or just somehow compatible? eg non_pos
1580 binds only E, but other_non_pos binds both E and E1 *)
1581 non_pos
=*= other_non_pos
)
1582 splitted_relevant in
1586 (combine_pos negated_pos_vars
1587 (List.map
(function (_,x
) -> x
) others)))))
1590 (List.map
(function (non_pos
,_) -> List.assoc non_pos
extended_relevant)
1593 (* If the negated posvar is not bound at all, this function will
1594 nevertheless bind it to []. If we get rid of these bindings, then the
1595 matching of the term the position variable with the constraints will fail
1596 because some variables are unbound. So we let the binding be [] and then
1597 we will have to clean these up afterwards. This should be the only way
1598 that a position variable can have an empty binding. *)
1599 and combine_pos negated_pos_vars
others =
1605 (function positions ->
1606 function other_list
->
1608 match List.assoc posvar other_list
with
1609 Ast_c.MetaPosValList l1
->
1610 Common.union_set l1
positions
1611 | _ -> failwith
"bad value for a position variable"
1612 with Not_found
-> positions)
1614 (posvar
,Ast_c.MetaPosValList
positions))
1617 and process_a_generated_a_env_a_toplevel2
r env = function
1622 (rule
,_) when rule
=$
= r.rule_info
.rulename
-> false
1623 | (_,"ARGS") -> false
1626 let env_domain = List.map
(function (nm
,vl
) -> nm
) env in
1630 let (rl
,_) = Ast_cocci.get_meta_name md
in rl
=$
= r.rule_info
.rulename
)
1632 if Common.include_set
free_vars env_domain
1633 then Unparse_hrule.pp_rule
metavars r.ast_rule
env cfile.full_fname
1634 | _ -> failwith
"multiple files not supported"
1636 and process_a_generated_a_env_a_toplevel rule
env ccs
=
1637 Common.profile_code
"process_a_ctl_a_env_a_toplevel"
1638 (fun () -> process_a_generated_a_env_a_toplevel2 rule
env ccs
)
1640 (* does side effects on C ast and on Cocci info rule *)
1641 and process_a_ctl_a_env_a_toplevel2
r e c
f =
1642 indent_do
(fun () ->
1643 show_or_not_celem "trying" c
.ast_c
;
1644 Flag.currentfile
:= Some
(f ^
":" ^
get_celem c
.ast_c
);
1645 match (r.ctl
,c
.ast_c
) with
1646 ((Asttoctl2.NONDECL ctl
,t
),Ast_c.Declaration
_) -> None
1647 | ((Asttoctl2.NONDECL ctl
,t
), _)
1648 | ((Asttoctl2.CODE ctl
,t
), _) ->
1649 let ctl = (ctl,t
) in (* ctl and other info *)
1650 let (trans_info, returned_any_states
, inherited_bindings
, newbindings
) =
1651 Common.save_excursion
Flag_ctl.loop_in_src_code
(fun () ->
1652 Flag_ctl.loop_in_src_code
:=
1653 !Flag_ctl.loop_in_src_code
||c
.contain_loop;
1655 (***************************************)
1656 (* !Main point! The call to the engine *)
1657 (***************************************)
1659 CCI.model_for_ctl
r.dropped_isos
(Common.some c
.flow) e
1660 in CCI.mysat
model_ctl ctl (r.rule_info
.used_after
, e))
1662 if not returned_any_states
1666 show_or_not_celem "found match in" c
.ast_c
;
1667 show_or_not_trans_info trans_info;
1668 List.iter
(show_or_not_binding "out") newbindings
;
1670 r.rule_info
.was_matched
:= true;
1672 if not
(null
trans_info) &&
1673 not
(!Flag.sgrep_mode2
&& not
!Flag_cocci.show_diff
)
1676 c
.was_modified
:= true;
1678 (* les "more than one var in a decl" et "already tagged token"
1679 * font crasher coccinelle. Si on a 5 fichiers, donc on a 5
1680 * failed. Le try limite le scope des crashes pendant la
1681 * trasformation au fichier concerne. *)
1683 (* modify ast via side effect *)
1685 (Transformation_c.transform
r.rule_info
.rulename
1687 inherited_bindings
trans_info (Common.some c
.flow));
1688 with Timeout
-> raise Timeout
| UnixExit i
-> raise
(UnixExit i
)
1691 Some
(List.map
(function x
-> x
@inherited_bindings
) newbindings
)
1695 and process_a_ctl_a_env_a_toplevel a b c
f=
1696 Common.profile_code
"process_a_ctl_a_env_a_toplevel"
1697 (fun () -> process_a_ctl_a_env_a_toplevel2 a b c
f)
1700 let rec bigloop2 rs
(ccs
: file_info list
) =
1701 let init_es = [(Ast_c.emptyMetavarsBinding
,[])] in
1702 let es = ref init_es in
1703 let ccs = ref ccs in
1704 let rules_that_have_ever_matched = ref [] in
1708 (* looping over the rules *)
1709 rs
+> List.iter
(fun r ->
1711 InitialScriptRuleCocciInfo
r | FinalScriptRuleCocciInfo
r -> ()
1712 | ScriptRuleCocciInfo
r ->
1713 if !Flag_cocci.show_ctl_text
then begin
1714 Common.pr_xxxxxxxxxxxxxxxxx
();
1715 pr
("script: " ^
r.language
);
1716 Common.pr_xxxxxxxxxxxxxxxxx
();
1718 adjust_pp_with_indent
(fun () ->
1719 Format.force_newline
();
1720 let (l,mv,script_vars
,code
) = r.scr_ast_rule
in
1721 let nm = r.scr_rule_info
.rulename
in
1722 let deps = r.scr_rule_info
.dependencies
in
1723 Pretty_print_cocci.unparse
1724 (Ast_cocci.ScriptRule
(nm,l,deps,mv,script_vars
,code
)));
1727 if !Flag.show_misc
then print_endline
"RESULT =";
1731 (function (cache
, newes
) ->
1732 function (e, rules_that_have_matched
) ->
1733 match r.language
with
1735 apply_script_rule r cache newes
e rules_that_have_matched
1736 rules_that_have_ever_matched python_application
1738 apply_script_rule r cache newes
e rules_that_have_matched
1739 rules_that_have_ever_matched ocaml_application
1741 concat_headers_and_c !ccs +> List.iter
(fun (c
,_) ->
1744 Printf.printf
"Flow: %s\r\nFlow!\r\n%!" c
.fullstring
);
1747 Printf.printf
"Unknown language: %s\n" r.language
;
1749 ([],init_env()) !es in
1751 (if !(r.scr_rule_info
.was_matched
)
1753 Common.push2
r.scr_rule_info
.rulename
rules_that_have_ever_matched);
1755 (* just newes can't work, because if one does include_match false
1756 on everything that binds a variable, then nothing is left *)
1758 (if Hashtbl.length newes
= 0 then init_es else end_env newes
)
1759 | CocciRuleCocciInfo
r ->
1760 apply_cocci_rule r rules_that_have_ever_matched
1764 if !Flag.sgrep_mode2
1766 (* sgrep can lead to code that is not parsable, but we must
1767 * still call rebuild_info_c_and_headers to pretty print the
1768 * action (MINUS), so that later the diff will show what was
1769 * matched by sgrep. But we don't want the parsing error message
1770 * hence the following flag setting. So this code propably
1771 * will generate a NotParsedCorrectly for the matched parts
1772 * and the very final pretty print and diff will work
1774 Flag_parsing_c.verbose_parsing
:= false;
1775 ccs := rebuild_info_c_and_headers !ccs false
1777 !ccs (* return final C asts *)
1780 Common.profile_code
"bigloop" (fun () -> bigloop2 a b
)
1782 type init_final
= Initial
| Final
1784 let initial_final_bigloop2 ty rebuild
r =
1785 if !Flag_cocci.show_ctl_text
then
1787 Common.pr_xxxxxxxxxxxxxxxxx
();
1788 pr
((match ty
with Initial
-> "initial" | Final
-> "final") ^
": " ^
1790 Common.pr_xxxxxxxxxxxxxxxxx
();
1792 adjust_pp_with_indent
(fun () ->
1793 Format.force_newline
();
1794 Pretty_print_cocci.unparse
(rebuild
r.scr_ast_rule
r.scr_rule_info
.dependencies
));
1797 match r.language
with
1799 (* include_match makes no sense in an initial or final rule, although
1800 we have no way to prevent it *)
1801 let newes = init_env() in
1802 let _ = apply_script_rule r [] newes [] [] (ref []) python_application in
1804 | "ocaml" when ty
= Initial
-> () (* nothing to do *)
1806 (* include_match makes no sense in an initial or final rule, although
1807 we have no way to prevent it *)
1808 let newes = init_env() in
1809 let _ = apply_script_rule r [] newes [] [] (ref []) ocaml_application in
1812 failwith
("Unknown language for initial/final script: "^
1815 let initial_final_bigloop a b c
=
1816 Common.profile_code
"initial_final_bigloop"
1817 (fun () -> initial_final_bigloop2 a b c
)
1819 (*****************************************************************************)
1820 (* The main functions *)
1821 (*****************************************************************************)
1823 let pre_engine2 (coccifile
, isofile
) =
1824 show_or_not_cocci coccifile isofile
;
1825 Pycocci.set_coccifile coccifile
;
1828 if not
(Common.lfile_exists
isofile)
1830 pr2
("warning: Can't find default iso file: " ^
isofile);
1833 else Some
isofile in
1835 (* useful opti when use -dir *)
1836 let (metavars,astcocci
,
1837 free_var_lists
,negated_pos_lists
,used_after_lists
,
1838 positions_lists
,(toks
,_,_)) =
1839 sp_of_file coccifile
isofile in
1840 let ctls = ctls_of_ast astcocci used_after_lists positions_lists
in
1842 g_contain_typedmetavar := sp_contain_typed_metavar astcocci
;
1844 check_macro_in_sp_and_adjust toks
;
1846 show_or_not_ctl_tex astcocci
ctls;
1849 prepare_cocci ctls free_var_lists negated_pos_lists
1850 used_after_lists positions_lists
metavars astcocci
in
1852 let used_languages =
1854 (function languages
->
1856 ScriptRuleCocciInfo
(r) ->
1857 if List.mem
r.language languages
then
1860 r.language
::languages
1865 let rlang = r.language
in
1866 let rname = r.scr_rule_info
.rulename
in
1868 let _ = List.assoc
(rlang,rname) !Iteration.initialization_stack
in
1872 Iteration.initialization_stack
:=
1873 ((rlang,rname),!Flag.defined_virtual_rules
) ::
1874 !Iteration.initialization_stack
;
1875 initial_final_bigloop Initial
1876 (fun (x
,_,_,y
) -> fun deps ->
1877 Ast_cocci.InitialScriptRule
(rname,x
,deps,y
))
1881 let initialized_languages =
1883 (function languages
->
1885 InitialScriptRuleCocciInfo
(r) ->
1886 let rlang = r.language
in
1887 (if List.mem
rlang languages
1888 then failwith
("double initializer found for "^
rlang));
1889 if interpret_dependencies [] [] r.scr_rule_info
.dependencies
1890 then begin runrule r; rlang::languages
end
1895 let uninitialized_languages =
1897 (fun used
-> not
(List.mem used
initialized_languages))
1904 dependencies
= Ast_cocci.NoDep
;
1907 was_matched
= ref false;} in
1908 runrule (make_init lgg
"" rule_info))
1909 uninitialized_languages;
1914 Common.profile_code
"pre_engine" (fun () -> pre_engine2 a
)
1916 let full_engine2 (cocci_infos,toks
) cfiles =
1918 show_or_not_cfiles cfiles;
1920 (* optimisation allowing to launch coccinelle on all the drivers *)
1921 if !Flag_cocci.worth_trying_opt
&& not
(worth_trying cfiles toks
)
1927 pr2
("No matches found for " ^
(Common.join
" " toks
)
1928 ^
"\nSkipping:" ^
(Common.join
" " cfiles)));
1929 cfiles +> List.map
(fun s -> s, None
)
1934 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1935 if !Flag.show_misc
then pr
"let's go";
1936 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1938 if !Flag_cocci.show_binding_in_out
1941 (match !Flag.defined_virtual_rules
with
1943 | l -> pr
(Printf.sprintf
"Defined virtual rules: %s"
1944 (String.concat
" " l)));
1947 pr
(Printf.sprintf
"%s = %s" v vl
))
1948 !Flag.defined_virtual_env
;
1949 Common.pr_xxxxxxxxxxxxxxxxx
()
1952 let choose_includes =
1953 match !Flag_cocci.include_options
with
1954 Flag_cocci.I_UNSPECIFIED
->
1955 if !g_contain_typedmetavar
1956 then Flag_cocci.I_NORMAL_INCLUDES
1957 else Flag_cocci.I_NO_INCLUDES
1959 let c_infos = prepare_c cfiles choose_includes in
1961 (* ! the big loop ! *)
1962 let c_infos'
= bigloop cocci_infos c_infos in
1964 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1965 if !Flag.show_misc
then pr
"Finished";
1966 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1967 if !Flag_ctl.graphical_trace
then gen_pdf_graph ();
1969 c_infos'
+> List.map
(fun c_or_h
->
1970 if !(c_or_h
.was_modified_once
)
1974 Common.new_temp_file
"cocci-output" ("-" ^ c_or_h
.fname
) in
1976 if c_or_h
.fkind
=*= Header
1977 then pr2
("a header file was modified: " ^ c_or_h
.fname
);
1979 (* and now unparse everything *)
1980 cfile_of_program (for_unparser c_or_h
.asts
) outfile;
1982 show_or_not_diff c_or_h
.fpath
outfile;
1985 if !Flag.sgrep_mode2
then None
else Some
outfile)
1987 else (c_or_h
.fpath
, None
))
1990 let full_engine a b
=
1991 Common.profile_code
"full_engine"
1992 (fun () -> let res = full_engine2 a b
in (*Gc.print_stat stderr; *)res)
1994 let post_engine2 (cocci_infos,_) =
1996 (function ((language
,_),virt_rules
) ->
1997 Flag.defined_virtual_rules
:= virt_rules
;
2000 (function languages
->
2002 FinalScriptRuleCocciInfo
(r) ->
2003 (if r.language
= language
&& List.mem
r.language languages
2004 then failwith
("double finalizer found for "^
r.language
));
2005 initial_final_bigloop Final
2006 (fun (x
,_,_,y
) -> fun deps ->
2007 Ast_cocci.FinalScriptRule
(r.scr_rule_info
.rulename
,
2010 r.language
::languages
2014 !Iteration.initialization_stack
2017 Common.profile_code
"post_engine" (fun () -> post_engine2 a
)
2019 (*****************************************************************************)
2020 (* check duplicate from result of full_engine *)
2021 (*****************************************************************************)
2023 let check_duplicate_modif2 xs =
2024 (* opti: let groups = Common.groupBy (fun (a,resa) (b,resb) -> a =$= b) xs *)
2025 if !Flag_cocci.verbose_cocci
2026 then pr2
("Check duplication for " ^ i_to_s
(List.length
xs) ^
" files");
2028 let groups = Common.group_assoc_bykey_eff
xs in
2029 groups +> Common.map_filter
(fun (file, xs) ->
2031 | [] -> raise Impossible
2032 | [res] -> Some
(file, res)
2036 if not
(List.for_all
(fun res2
-> res2
=*= None
) xs)
2038 pr2
("different modification result for " ^
file);
2041 else Some
(file, None
)
2043 if not
(List.for_all
(fun res2
->
2047 let diff = Common.cmd_to_list
("diff -u -b -B "^
res^
" "^res2
)
2051 pr2
("different modification result for " ^
file);
2054 else Some
(file, Some
res)
2056 let check_duplicate_modif a
=
2057 Common.profile_code
"check_duplicate" (fun () -> check_duplicate_modif2 a
)