2 * Copyright 2012, INRIA
3 * Julia Lawall, Gilles Muller
4 * Copyright 2010-2011, INRIA, University of Copenhagen
5 * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
6 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
7 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
8 * This file is part of Coccinelle.
10 * Coccinelle is free software: you can redistribute it and/or modify
11 * it under the terms of the GNU General Public License as published by
12 * the Free Software Foundation, according to version 2 of the License.
14 * Coccinelle is distributed in the hope that it will be useful,
15 * but WITHOUT ANY WARRANTY; without even the implied warranty of
16 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 * GNU General Public License for more details.
19 * You should have received a copy of the GNU General Public License
20 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
22 * The authors reserve the right to distribute this or future versions of
23 * Coccinelle under other licenses.
30 module CCI
= Ctlcocci_integration
31 module TAC
= Type_annoter_c
33 module Ast_to_flow
= Control_flow_c_build
35 (*****************************************************************************)
36 (* This file is a kind of driver. It gathers all the important functions
37 * from coccinelle in one place. The different entities in coccinelle are:
41 * - flow (contain nodes)
42 * - ctl (contain rule_elems)
43 * This file contains functions to transform one in another.
45 (*****************************************************************************)
47 (* --------------------------------------------------------------------- *)
49 (* --------------------------------------------------------------------- *)
50 let cprogram_of_file saved_typedefs saved_macros file
=
51 let (program2
, _stat
) =
52 Parse_c.parse_c_and_cpp_keep_typedefs
53 (if !Flag_cocci.use_saved_typedefs
then (Some saved_typedefs
) else None
)
54 (Some saved_macros
) file
in
57 let cprogram_of_file_cached file
=
58 let ((program2
,typedefs
,macros
), _stat
) = Parse_c.parse_cache file
in
59 if !Flag_cocci.ifdef_to_if
62 program2
+> Parse_c.with_program2
(fun asts
->
63 Cpp_ast_c.cpp_ifdef_statementize asts
66 else (program2
,typedefs
,macros
)
68 let cfile_of_program program2_with_ppmethod outf
=
69 Unparse_c.pp_program program2_with_ppmethod outf
71 (* for memoization, contains only one entry, the one for the SP *)
72 let _hparse = Hashtbl.create
101
73 let _h_ocaml_init = Hashtbl.create
101
74 let _hctl = Hashtbl.create
101
76 (* --------------------------------------------------------------------- *)
78 (* --------------------------------------------------------------------- *)
79 (* for a given pair (file,iso), only keep an instance for the most recent
80 virtual rules and virtual_env *)
82 let sp_of_file2 file iso
=
85 let (_
,xs
,_
,_
,_
,_
,_
) as res
= Parse_cocci.process file iso
false in
86 (* if there is already a compiled ML code, do nothing and use that *)
87 try let _ = Hashtbl.find
_h_ocaml_init (file
,iso
) in res
90 Hashtbl.add
_h_ocaml_init (file
,iso
) ();
91 match Prepare_ocamlcocci.prepare file xs
with
93 | Some ocaml_script_file
->
95 Prepare_ocamlcocci.load_file ocaml_script_file
;
96 (if not
!Common.save_tmp_files
97 then Prepare_ocamlcocci.clean_file ocaml_script_file
);
100 Hashtbl.add
_hparse (file
,iso
)
101 (!Flag.defined_virtual_rules
,!Flag.defined_virtual_env
,new_code);
104 let (rules
,env
,code
) = Hashtbl.find
_hparse (file
,iso
) in
105 if rules
= !Flag.defined_virtual_rules
&& env
= !Flag.defined_virtual_env
107 else (Hashtbl.remove
_hparse (file
,iso
); redo())
108 with Not_found
-> redo()
110 let sp_of_file file iso
=
111 Common.profile_code
"parse cocci" (fun () -> sp_of_file2 file iso
)
114 (* --------------------------------------------------------------------- *)
116 (* --------------------------------------------------------------------- *)
117 let print_flow flow
=
118 Ograph_extended.print_ograph_mutable flow
"/tmp/test.dot" true
121 let ast_to_flow_with_error_messages2 x
=
123 try Ast_to_flow.ast_to_control_flow x
124 with Ast_to_flow.Error x
->
125 Ast_to_flow.report_error x
;
128 flowopt +> do_option
(fun flow
->
129 (* This time even if there is a deadcode, we still have a
130 * flow graph, so I can try the transformation and hope the
131 * deadcode will not bother us.
133 try Ast_to_flow.deadcode_detection flow
134 with Ast_to_flow.Error
(Ast_to_flow.DeadCode x
) ->
135 Ast_to_flow.report_error
(Ast_to_flow.DeadCode x
);
138 let ast_to_flow_with_error_messages a
=
139 Common.profile_code
"flow" (fun () -> ast_to_flow_with_error_messages2 a
)
142 (* --------------------------------------------------------------------- *)
144 (* --------------------------------------------------------------------- *)
146 let ctls_of_ast2 ast
(ua
,fua
,fuas
) pos
=
148 (function ast
-> function (ua
,(fua
,(fuas
,pos
))) ->
152 else Asttoctl2.asttoctl ast
(ua
,fua
,fuas
) pos
)
153 (Asttomember.asttomember ast ua
))
154 ast
(List.combine ua
(List.combine fua
(List.combine fuas pos
)))
156 let ctls_of_ast ast ua pl
=
157 Common.profile_code
"asttoctl2" (fun () -> ctls_of_ast2 ast ua pl
)
159 (*****************************************************************************)
160 (* Some debugging functions *)
161 (*****************************************************************************)
165 let show_or_not_cfile2 cfile
=
166 if !Flag_cocci.show_c
then begin
167 Common.pr2_xxxxxxxxxxxxxxxxx
();
168 pr2
("processing C file: " ^ cfile
);
169 Common.pr2_xxxxxxxxxxxxxxxxx
();
170 Common.command2
("cat " ^ cfile
);
172 let show_or_not_cfile a
=
173 Common.profile_code
"show_xxx" (fun () -> show_or_not_cfile2 a
)
175 let show_or_not_cfiles cfiles
= List.iter
show_or_not_cfile cfiles
178 let show_or_not_cocci2 coccifile isofile
=
179 if !Flag_cocci.show_cocci
then begin
180 Common.pr2_xxxxxxxxxxxxxxxxx
();
181 pr2
("processing semantic patch file: " ^ coccifile
);
182 isofile
+> (fun s
-> pr2
("with isos from: " ^ s
));
183 Common.pr2_xxxxxxxxxxxxxxxxx
();
184 Common.command2
("cat " ^ coccifile
);
187 let show_or_not_cocci a b
=
188 Common.profile_code
"show_xxx" (fun () -> show_or_not_cocci2 a b
)
190 (* ---------------------------------------------------------------------- *)
193 let fix_sgrep_diffs l
=
195 List.filter
(function s
-> (s
=~
"^\\+\\+\\+") || not
(s
=~
"^\\+")) l in
196 let l = List.rev
l in
197 (* adjust second number for + code *)
198 let rec loop1 n
= function
201 if s
=~
"^-" && not
(s
=~
"^---")
202 then s
:: loop1 (n
+1) ss
205 (match Str.split
(Str.regexp
" ") s
with
208 match Str.split
(Str.regexp
",") pl
with
211 | _ -> failwith
"bad + line information" in
212 let n2 = int_of_string
n2 in
213 (Printf.sprintf
"%s %s %s,%d %s" bef min n1
(n2-n
)
214 (String.concat
" " aft
))
216 | _ -> failwith
"bad @@ information")
217 else s
:: loop1 n ss
in
218 let rec loop2 n
= function
225 (match Str.split
(Str.regexp
" ") s
with
228 match (Str.split
(Str.regexp
",") min
,
229 Str.split
(Str.regexp
",") pl
) with
230 ([_;m2
],[n1
;n2]) -> (m2
,n1
,n2)
231 | ([_],[n1
;n2]) -> ("1",n1
,n2)
232 | ([_;m2
],[n1
]) -> (m2
,n1
,"1")
233 | ([_],[n1
]) -> ("1",n1
,"1")
234 | _ -> failwith
"bad -/+ line information" in
236 int_of_string
(String.sub
n1 1 ((String.length
n1)-1)) in
237 let m2 = int_of_string
m2 in
238 let n2 = int_of_string
n2 in
239 (Printf.sprintf
"%s %s +%d,%d %s" bef min
(n1-n
) n2
240 (String.concat
" " aft
))
241 :: loop2 (n
+(m2-n2)) ss
242 | _ -> failwith
"bad @@ information")
243 else s
:: loop2 n ss
in
244 loop2 0 (List.rev
(loop1 0 l))
246 let normalize_path file
=
248 if String.get file
0 = '
/'
then file
else (Sys.getcwd
()) ^
"/" ^ file
in
249 let elements = Str.split_delim
(Str.regexp
"/") fullpath in
250 let rec loop prev
= function
251 [] -> String.concat
"/" (List.rev prev
)
252 | "." :: rest
-> loop prev rest
255 x
::xs
-> loop xs rest
256 | _ -> failwith
"bad path")
257 | x
::rest
-> loop (x
::prev
) rest
in
260 let generated_patches = Hashtbl.create
(100)
262 let show_or_not_diff2 cfile outfile
=
263 if !Flag_cocci.show_diff
then begin
264 match Common.fst
(Compare_c.compare_to_original cfile outfile
) with
265 Compare_c.Correct
-> () (* diff only in spacing, etc *)
267 (* may need --strip-trailing-cr under windows *)
271 match !Flag_parsing_c.diff_lines
with
272 | None
-> "diff -u -p " ^ cfile ^
" " ^ outfile
273 | Some n
-> "diff -U "^n^
" -p "^cfile^
" "^outfile
in
274 let res = Common.cmd_to_list
line in
278 match Str.split
(Str.regexp
"[ \t]+") l with
279 "---"::file
::date
-> "--- "^file
280 | "+++"::file
::date
-> "+++ "^file
284 match (!Flag.patch
,res) with
285 (* create something that looks like the output of patch *)
286 (Some prefix
,minus_file
::plus_file
::rest
) ->
288 let lp = String.length
prefix in
289 if String.get
prefix (lp-1) = '
/'
290 then String.sub
prefix 0 (lp-1)
292 let drop_prefix file
=
293 let file = normalize_path file in
294 if Str.string_match
(Str.regexp
prefix) file 0
296 let lp = String.length
prefix in
297 let lf = String.length
file in
299 then String.sub
file lp (lf - lp)
302 (Printf.sprintf
"prefix %s doesn't match file %s"
306 (Printf.sprintf
"prefix %s doesn't match file %s"
309 match List.rev
(Str.split
(Str.regexp
" ") line) with
310 new_file
::old_file
::cmdrev
->
311 let old_base_file = drop_prefix old_file
in
316 (("/tmp/nothing"^
old_base_file)
317 :: old_file
:: cmdrev
))
321 (("b"^
old_base_file)::("a"^
old_base_file)::
323 | _ -> failwith
"bad command" in
324 let (minus_line
,plus_line
) =
325 match (Str.split
(Str.regexp
"[ \t]") minus_file
,
326 Str.split
(Str.regexp
"[ \t]") plus_file
) with
327 ("---"::old_file
::old_rest
,"+++"::new_file
::new_rest
) ->
328 let old_base_file = drop_prefix old_file
in
330 then (minus_file
,"+++ /tmp/nothing"^
old_base_file)
333 ("---"::("a"^
old_base_file)::old_rest
),
335 ("+++"::("b"^
old_base_file)::new_rest
))
338 (Printf.sprintf
"bad diff header lines: %s %s"
339 (String.concat
":" l1
) (String.concat
":" l2
)) in
340 diff_line::minus_line
::plus_line
::rest
342 let xs = if !Flag.sgrep_mode2
then fix_sgrep_diffs xs else xs in
343 let cfile = normalize_path cfile in
345 try Hashtbl.find
generated_patches cfile
348 Hashtbl.add
generated_patches cfile cell;
350 if List.mem
xs !patches
354 patches := xs :: !patches;
358 let show_or_not_diff a b
=
359 Common.profile_code
"show_xxx" (fun () -> show_or_not_diff2 a b
)
362 (* the derived input *)
364 let show_or_not_ctl_tex2 astcocci ctls
=
365 if !Flag_cocci.show_ctl_tex
then begin
369 (function ((Asttoctl2.NONDECL ctl
| Asttoctl2.CODE ctl
),x
) ->
372 Ctltotex.totex
("/tmp/__cocci_ctl.tex") astcocci
ctls;
373 Common.command2
("cd /tmp; latex __cocci_ctl.tex; " ^
374 "dvips __cocci_ctl.dvi -o __cocci_ctl.ps;" ^
375 "gv __cocci_ctl.ps &");
377 let show_or_not_ctl_tex a b
=
378 Common.profile_code
"show_xxx" (fun () -> show_or_not_ctl_tex2 a b
)
381 let show_or_not_rule_name ast rulenb
=
382 if !Flag_cocci.show_ctl_text
or !Flag.show_trying
or
383 !Flag.show_transinfo
or !Flag_cocci.show_binding_in_out
388 Ast_cocci.CocciRule
(nm
, (deps
, drops
, exists
), x
, _, _) -> nm
389 | _ -> i_to_s rulenb
in
390 Common.pr_xxxxxxxxxxxxxxxxx
();
392 Common.pr_xxxxxxxxxxxxxxxxx
()
395 let show_or_not_scr_rule_name rulenb
=
396 if !Flag_cocci.show_ctl_text
or !Flag.show_trying
or
397 !Flag.show_transinfo
or !Flag_cocci.show_binding_in_out
400 let name = i_to_s rulenb
in
401 Common.pr_xxxxxxxxxxxxxxxxx
();
402 pr
("script rule " ^
name ^
" = ");
403 Common.pr_xxxxxxxxxxxxxxxxx
()
406 let show_or_not_ctl_text2 ctl ast rulenb
=
407 if !Flag_cocci.show_ctl_text
then begin
409 adjust_pp_with_indent
(fun () ->
410 Format.force_newline
();
411 Pretty_print_cocci.print_plus_flag
:= true;
412 Pretty_print_cocci.print_minus_flag
:= true;
413 Pretty_print_cocci.unparse ast
;
417 let ((Asttoctl2.CODE ctl
| Asttoctl2.NONDECL ctl
),_) = ctl
in
418 adjust_pp_with_indent
(fun () ->
419 Format.force_newline
();
420 Pretty_print_engine.pp_ctlcocci
421 !Flag_cocci.show_mcodekind_in_ctl
!Flag_cocci.inline_let_ctl ctl
;
425 let show_or_not_ctl_text a b c
=
426 Common.profile_code
"show_xxx" (fun () -> show_or_not_ctl_text2 a b c
)
430 (* running information *)
431 let get_celem celem
: string =
433 Ast_c.Definition
({Ast_c.f_name
= namefuncs
;},_) ->
434 Ast_c.str_of_name namefuncs
436 (Ast_c.DeclList
([{Ast_c.v_namei
= Some
(name, _);}, _], _)) ->
437 Ast_c.str_of_name
name
440 let show_or_not_celem2 prelude celem
=
443 | Ast_c.Definition
({Ast_c.f_name
= namefuncs
},_) ->
444 let funcs = Ast_c.str_of_name namefuncs
in
445 Flag.current_element
:= funcs;
446 (" function: ",funcs)
448 (Ast_c.DeclList
([{Ast_c.v_namei
= Some
(name,_)}, _], _)) ->
449 let s = Ast_c.str_of_name
name in
450 Flag.current_element
:= s;
453 Flag.current_element
:= "something_else";
454 (" ","something else");
456 if !Flag.show_trying
then pr2
(prelude ^ tag ^ trying
)
458 let show_or_not_celem a b
=
459 Common.profile_code
"show_xxx" (fun () -> show_or_not_celem2 a b
)
462 let show_or_not_trans_info2 trans_info
=
463 (* drop witness tree indices for printing *)
465 List.map
(function (index
,trans_info) -> trans_info) trans_info in
466 if !Flag.show_transinfo
then begin
467 if null
trans_info then pr2
"transformation info is empty"
469 pr2
"transformation info returned:";
471 List.sort
(function (i1
,_,_) -> function (i2
,_,_) -> compare i1 i2
)
475 trans_info +> List.iter
(fun (i
, subst
, re
) ->
476 pr2
("transform state: " ^
(Common.i_to_s i
));
478 adjust_pp_with_indent_and_header
"with rule_elem: " (fun () ->
479 Pretty_print_cocci.print_plus_flag
:= true;
480 Pretty_print_cocci.print_minus_flag
:= true;
481 Pretty_print_cocci.rule_elem
"" re
;
483 adjust_pp_with_indent_and_header
"with binding: " (fun () ->
484 Pretty_print_engine.pp_binding subst
;
491 let show_or_not_trans_info a
=
492 Common.profile_code
"show_xxx" (fun () -> show_or_not_trans_info2 a
)
496 let show_or_not_binding2 s binding
=
497 if !Flag_cocci.show_binding_in_out
then begin
498 adjust_pp_with_indent_and_header
("binding " ^
s ^
" = ") (fun () ->
499 Pretty_print_engine.pp_binding binding
502 let show_or_not_binding a b
=
503 Common.profile_code
"show_xxx" (fun () -> show_or_not_binding2 a b
)
507 (*****************************************************************************)
508 (* Some helper functions *)
509 (*****************************************************************************)
511 let worth_trying cfiles tokens
=
512 (* drop the following line for a list of list by rules. since we don't
513 allow multiple minirules, all the tokens within a rule should be in
514 a single CFG entity *)
515 match (!Flag_cocci.windows
,tokens
) with
516 (true,_) | (_,None
) -> true
518 (* could also modify the code in get_constants.ml *)
519 let tokens = tokens +> List.map
(fun s ->
521 | _ when s =~
"^[A-Za-z_][A-Za-z_0-9]*$" ->
524 | _ when s =~
"^[A-Za-z_]" ->
527 | _ when s =~
".*[A-Za-z_]$" ->
532 let com = sprintf
"egrep -q '(%s)' %s" (join
"|" tokens) (join
" " cfiles
)
534 (match Sys.command
com with
535 | 0 (* success *) -> true
538 then Printf.printf
"grep failed: %s\n" com);
539 false (* no match, so not worth trying *))
541 let check_macro_in_sp_and_adjust = function
544 tokens +> List.iter
(fun s ->
545 if Hashtbl.mem
!Parse_c._defs
s
547 if !Flag_cocci.verbose_cocci
then begin
548 pr2
"warning: macro in semantic patch was in macro definitions";
549 pr2
("disabling macro expansion for " ^
s);
551 Hashtbl.remove
!Parse_c._defs
s
555 let contain_loop gopt
=
558 g#nodes#tolist
+> List.exists
(fun (xi
, node
) ->
559 Control_flow_c.extract_is_loop node
561 | None
-> true (* means nothing, if no g then will not model check *)
565 let sp_contain_typed_metavar_z toplevel_list_list
=
566 let bind x y
= x
or y
in
567 let option_default = false in
568 let mcode _ _ = option_default in
569 let donothing r k e
= k e
in
571 let expression r k e
=
572 match Ast_cocci.unwrap e
with
573 | Ast_cocci.MetaExpr
(_,_,_,Some t
,_,_) -> true
574 | Ast_cocci.MetaExpr
(_,_,_,_,Ast_cocci.LocalID
,_) -> true
579 Visitor_ast.combiner bind option_default
580 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
581 donothing donothing donothing donothing donothing
582 donothing expression donothing donothing donothing donothing donothing
583 donothing donothing donothing donothing donothing
585 toplevel_list_list
+>
587 (function (nm
,_,rule
) ->
588 (List.exists
combiner.Visitor_ast.combiner_top_level rule
))
590 let sp_contain_typed_metavar rules
=
591 sp_contain_typed_metavar_z
595 Ast_cocci.CocciRule
(a
,b
,c
,d
,_) -> (a
,b
,c
)
596 | _ -> failwith
"error in filter")
600 Ast_cocci.CocciRule
(a
,b
,c
,d
,Ast_cocci.Normal
) -> true
606 (* finding among the #include the one that we need to parse
607 * because they may contain useful type definition or because
608 * we may have to modify them
610 * For the moment we base in part our heuristic on the name of the file, e.g.
611 * serio.c is related we think to #include <linux/serio.h>
613 let include_table = Hashtbl.create
(100)
615 let interpret_include_path relpath
=
616 let maxdepth = List.length relpath
in
617 let unique_file_exists dir f
=
619 Printf.sprintf
"find %s -maxdepth %d -mindepth %d -path \"*/%s\""
620 dir
maxdepth maxdepth f
in
621 match Common.cmd_to_list
cmd with
624 let native_file_exists dir f
=
625 let f = Filename.concat dir
f in
629 let rec search_include_path exists searchlist relpath
=
630 match searchlist
with
633 (match exists hd relpath
with
635 | None
-> search_include_path exists tail relpath
) in
636 let rec search_path exists searchlist
= function
638 let res = Common.concat
"/" relpath
in
639 Hashtbl.add
include_table (searchlist
,relpath
) res;
641 | (hd
::tail
) as relpath1
->
642 let relpath1 = Common.concat
"/" relpath1 in
643 (match search_include_path exists searchlist
relpath1 with
644 None
-> search_path unique_file_exists searchlist tail
646 Hashtbl.add
include_table (searchlist
,relpath
) f;
649 match !Flag_cocci.include_path
with
652 try Some
(Hashtbl.find
include_table (searchlist,relpath
))
654 search_path native_file_exists searchlist relpath
656 let (includes_to_parse
:
657 (Common.filename
* Parse_c.extended_program2
) list
->
658 Flag_cocci.include_options
-> 'a
) = fun xs choose_includes
->
659 match choose_includes
with
660 Flag_cocci.I_UNSPECIFIED
-> failwith
"not possible"
661 | Flag_cocci.I_NO_INCLUDES
-> []
665 [Flag_cocci.I_ALL_INCLUDES
; Flag_cocci.I_REALLY_ALL_INCLUDES
] in
666 let xs = List.map
(function (file,(cs
,_,_)) -> (file,cs
)) xs in
667 xs +> List.map
(fun (file, cs
) ->
668 let dir = Common.dirname
file in
670 cs
+> Common.map_filter
(fun (c
,_info_item
) ->
674 {Ast_c.i_include
= ((x
,ii
)); i_rel_pos
= info_h_pos
;}) ->
677 let relpath = Common.join
"/" xs in
678 let f = Filename.concat
dir relpath in
679 if (Sys.file_exists
f) then
682 if !Flag_cocci.relax_include_path
683 (* for our tests, all the files are flat in the current dir *)
685 let attempt2 = Filename.concat
dir (Common.last
xs) in
686 if not
(Sys.file_exists
attempt2) && all_includes
688 interpret_include_path xs
691 if all_includes then interpret_include_path xs
694 | Ast_c.NonLocal
xs ->
696 Common.fileprefix
(Common.last
xs) =$
= Common.fileprefix
file
698 interpret_include_path xs
700 | Ast_c.Weird
_ -> None
704 +> (fun x
-> (List.rev
(Common.uniq
(List.rev x
)))) (*uniq keeps last*)
706 let rec interpret_dependencies local global
= function
707 Ast_cocci.Dep
s -> List.mem
s local
708 | Ast_cocci.AntiDep
s ->
709 (if !Flag_ctl.steps
!= None
710 then failwith
"steps and ! dependency incompatible");
711 not
(List.mem
s local
)
712 | Ast_cocci.EverDep
s -> List.mem
s global
713 | Ast_cocci.NeverDep
s ->
714 (if !Flag_ctl.steps
!= None
715 then failwith
"steps and ! dependency incompatible");
716 not
(List.mem
s global
)
717 | Ast_cocci.AndDep
(s1
,s2
) ->
718 (interpret_dependencies local global s1
) &&
719 (interpret_dependencies local global s2
)
720 | Ast_cocci.OrDep
(s1
,s2
) ->
721 (interpret_dependencies local global s1
) or
722 (interpret_dependencies local global s2
)
723 | Ast_cocci.NoDep
-> true
724 | Ast_cocci.FailDep
-> false
726 let rec print_dependencies str local global dep
=
727 if !Flag_cocci.show_dependencies
732 let rec loop = function
733 Ast_cocci.Dep
s | Ast_cocci.AntiDep
s ->
734 if not
(List.mem
s !seen)
738 then pr2
(s^
" satisfied")
739 else pr2
(s^
" not satisfied");
742 | Ast_cocci.EverDep
s | Ast_cocci.NeverDep
s ->
743 if not
(List.mem
s !seen)
747 then pr2
(s^
" satisfied")
748 else pr2
(s^
" not satisfied");
751 | Ast_cocci.AndDep
(s1
,s2
) ->
754 | Ast_cocci.OrDep
(s1
,s2
) ->
757 | Ast_cocci.NoDep
-> ()
758 | Ast_cocci.FailDep
-> pr2
"False not satisfied" in
762 (* --------------------------------------------------------------------- *)
763 (* #include relative position in the file *)
764 (* --------------------------------------------------------------------- *)
766 (* compute the set of new prefixes
768 * "a/b/x"; (* in fact it is now a list of string so ["a";"b";"x"] *)
772 * it would give
for the first element
773 * ""; "a"; "a/b"; "a/b/x"
777 * update
: if the
include is inside a ifdef a put nothing
. cf
-test incl
.
778 * this is because we dont want code added inside ifdef
.
781 let compute_new_prefixes xs =
782 xs +> Common.map_withenv
(fun already
xs ->
783 let subdirs_prefixes = Common.inits
xs in
784 let new_first = subdirs_prefixes +> List.filter
(fun x
->
785 not
(List.mem x already
)
794 (* does via side effect on the ref in the Include in Ast_c *)
795 let rec update_include_rel_pos cs
=
796 let only_include = cs
+> Common.map_filter
(fun c
->
798 | Ast_c.CppTop
(Ast_c.Include
{Ast_c.i_include
= ((x
,_));
800 i_is_in_ifdef
= inifdef
}) ->
802 | Ast_c.Weird
_ -> None
811 let (locals
, nonlocals
) =
812 only_include +> Common.partition_either
(fun (c
, aref
) ->
814 | Ast_c.Local x
-> Left
(x
, aref
)
815 | Ast_c.NonLocal x
-> Right
(x
, aref
)
816 | Ast_c.Weird x
-> raise Impossible
819 update_rel_pos_bis locals
;
820 update_rel_pos_bis nonlocals
;
822 and update_rel_pos_bis
xs =
823 let xs'
= List.map fst
xs in
824 let the_first = compute_new_prefixes xs'
in
825 let the_last = List.rev
(compute_new_prefixes (List.rev
xs'
)) in
826 let merged = Common.zip
xs (Common.zip
the_first the_last) in
827 merged +> List.iter
(fun ((x
, aref
), (the_first, the_last)) ->
830 Ast_c.first_of
= the_first;
831 Ast_c.last_of
= the_last;
836 (*****************************************************************************)
837 (* All the information needed around the C elements and Cocci rules *)
838 (*****************************************************************************)
840 type toplevel_c_info
= {
841 ast_c
: Ast_c.toplevel
; (* contain refs so can be modified *)
842 tokens_c
: Parser_c.token list
;
845 flow
: Control_flow_c.cflow
option; (* it's the "fixed" flow *)
848 env_typing_before
: TAC.environment
;
849 env_typing_after
: TAC.environment
;
851 was_modified
: bool ref;
853 all_typedefs
: (string, Lexer_parser.identkind
) Common.scoped_h_env
;
854 all_macros
: (string, Cpp_token_c.define_def
) Hashtbl.t
;
861 dependencies
: Ast_cocci.dependency
;
862 used_after
: Ast_cocci.meta_name list
;
864 was_matched
: bool ref;
867 type toplevel_cocci_info_script_rule
= {
870 (Ast_cocci.script_meta_name
* Ast_cocci.meta_name
*
871 Ast_cocci.metavar
) list
*
872 Ast_cocci.meta_name list
(*fresh vars*) *
876 scr_rule_info
: rule_info
;
879 type toplevel_cocci_info_cocci_rule
= {
880 ctl
: Asttoctl2.top_formula
* (CCI.pred list list
);
881 metavars
: Ast_cocci.metavar list
;
882 ast_rule
: Ast_cocci.rule
;
883 isexp
: bool; (* true if + code is an exp, only for Flag.make_hrule *)
885 (* There are also some hardcoded rule names in parse_cocci.ml:
886 * let reserved_names = ["all";"optional_storage";"optional_qualifier"]
888 dropped_isos
: string list
;
889 free_vars
: Ast_cocci.meta_name list
;
890 negated_pos_vars
: Ast_cocci.meta_name list
;
891 positions
: Ast_cocci.meta_name list
;
893 ruletype
: Ast_cocci.ruletype
;
895 rule_info
: rule_info
;
898 type toplevel_cocci_info
=
899 ScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
900 | InitialScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
901 | FinalScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
902 | CocciRuleCocciInfo
of toplevel_cocci_info_cocci_rule
904 type cocci_info
= toplevel_cocci_info list
* string list
option (* tokens *)
906 type kind_file
= Header
| Source
910 was_modified_once
: bool ref;
911 asts
: toplevel_c_info list
;
916 let g_contain_typedmetavar = ref false
919 let last_env_toplevel_c_info xs =
920 (Common.last
xs).env_typing_after
922 let concat_headers_and_c (ccs
: file_info list
)
923 : (toplevel_c_info
* string) list
=
924 (List.concat
(ccs
+> List.map
(fun x
->
925 x
.asts
+> List.map
(fun x'
->
928 let for_unparser xs =
929 xs +> List.map
(fun x
->
930 (x
.ast_c
, (x
.fullstring
, x
.tokens_c
)), Unparse_c.PPviastr
933 let gen_pdf_graph () =
934 (Ctl_engine.get_graph_files
()) +> List.iter
(fun outfile
->
935 Printf.printf
"Generation of %s%!" outfile
;
936 let filename_stack = Ctl_engine.get_graph_comp_files outfile
in
937 List.iter
(fun filename
->
938 ignore
(Unix.system
("dot " ^ filename ^
" -Tpdf -o " ^ filename ^
".pdf;"))
940 let (head
,tail
) = (List.hd
filename_stack, List.tl
filename_stack) in
941 ignore
(Unix.system
("cp " ^ head ^
".pdf " ^ outfile ^
".pdf;"));
942 tail
+> List.iter
(fun filename
->
943 ignore
(Unix.system
("mv " ^ outfile ^
".pdf /tmp/tmp.pdf;"));
944 ignore
(Unix.system
("pdftk " ^ filename ^
".pdf /tmp/tmp.pdf cat output " ^ outfile ^
".pdf"));
946 ignore
(Unix.system
("rm /tmp/tmp.pdf;"));
947 List.iter
(fun filename
->
948 ignore
(Unix.system
("rm " ^ filename ^
" " ^ filename ^
".pdf;"))
950 Printf.printf
" - Done\n")
952 let local_python_code =
953 "from coccinelle import *\n"
956 "import coccinelle\n"^
958 "import coccilib.org\n"^
959 "import coccilib.report\n" ^
963 let make_init lang code rule_info
=
966 scr_ast_rule
= (lang
, mv, [], code
);
968 script_code
= (if lang
= "python" then python_code else "") ^code
;
969 scr_rule_info
= rule_info
;
972 (* --------------------------------------------------------------------- *)
973 let prepare_cocci ctls free_var_lists negated_pos_lists
974 (ua
,fua
,fuas
) positions_list metavars astcocci
=
976 let gathered = Common.index_list_1
977 (zip
(zip
(zip
(zip
(zip
(zip
(zip
(zip
ctls metavars
) astcocci
)
979 negated_pos_lists
) ua
) fua
) fuas
) positions_list
)
982 (fun (((((((((ctl_toplevel_list
,metavars
),ast
),free_var_list
),
983 negated_pos_list
),ua
),fua
),fuas
),positions_list
),rulenb
) ->
985 let build_rule_info rulename deps
=
986 {rulename
= rulename
;
988 used_after
= (List.hd ua
) @ (List.hd fua
);
990 was_matched
= ref false;} in
992 let is_script_rule r
=
994 Ast_cocci.ScriptRule
_
995 | Ast_cocci.InitialScriptRule
_ | Ast_cocci.FinalScriptRule
_ -> true
998 if not
(List.length ctl_toplevel_list
=|= 1) && not
(is_script_rule ast
)
999 then failwith
"not handling multiple minirules";
1002 Ast_cocci.ScriptRule
(name,lang
,deps
,mv,script_vars
,code
) ->
1005 scr_ast_rule
= (lang
, mv, script_vars
, code
);
1008 scr_rule_info
= build_rule_info name deps
;
1010 in ScriptRuleCocciInfo
r
1011 | Ast_cocci.InitialScriptRule
(name,lang
,deps
,code
) ->
1012 let r = make_init lang code
(build_rule_info name deps
) in
1013 InitialScriptRuleCocciInfo
r
1014 | Ast_cocci.FinalScriptRule
(name,lang
,deps
,code
) ->
1018 scr_ast_rule
= (lang
, mv, [], code
);
1021 scr_rule_info
= build_rule_info name deps
;
1023 in FinalScriptRuleCocciInfo
r
1024 | Ast_cocci.CocciRule
1025 (rulename
,(dependencies
,dropped_isos
,z
),restast
,isexp
,ruletype
) ->
1026 CocciRuleCocciInfo
(
1028 ctl
= List.hd ctl_toplevel_list
;
1029 metavars
= metavars
;
1031 isexp
= List.hd isexp
;
1032 dropped_isos
= dropped_isos
;
1033 free_vars
= List.hd free_var_list
;
1034 negated_pos_vars
= List.hd negated_pos_list
;
1035 positions
= List.hd positions_list
;
1036 ruletype
= ruletype
;
1037 rule_info
= build_rule_info rulename dependencies
;
1041 (* --------------------------------------------------------------------- *)
1043 let build_info_program (cprogram
,typedefs
,macros
) env
=
1045 let (cs
, parseinfos
) =
1046 Common.unzip cprogram
in
1049 parseinfos
+> List.map
(fun (s,toks
) -> toks
) +> List.flatten
in
1051 (* I use cs' but really annotate_xxx work by doing side effects on cs *)
1053 Comment_annotater_c.annotate_program
alltoks cs in
1056 Type_annoter_c.annotate_program env
(*!g_contain_typedmetavar*) cs'
1059 zip
cs_with_envs parseinfos
+> List.map
(fun ((c
, (enva
,envb
)), parseinfo
)->
1060 let (fullstr
, tokens) = parseinfo
in
1063 ast_to_flow_with_error_messages c
+>
1064 Common.map_option
(fun flow ->
1065 let flow = Ast_to_flow.annotate_loop_nodes
flow in
1067 (* remove the fake nodes for julia *)
1068 let fixed_flow = CCI.fix_flow_ctl
flow in
1070 if !Flag_cocci.show_flow
then print_flow fixed_flow;
1071 if !Flag_cocci.show_before_fixed_flow
then print_flow flow;
1078 ast_c
= c
; (* contain refs so can be modified *)
1080 fullstring
= fullstr
;
1084 contain_loop = contain_loop flow;
1086 env_typing_before
= enva
;
1087 env_typing_after
= envb
;
1089 was_modified
= ref false;
1091 all_typedefs
= typedefs
;
1092 all_macros
= macros
;
1098 (* Optimisation. Try not unparse/reparse the whole file when have modifs *)
1099 let rebuild_info_program cs file isexp
=
1100 cs +> List.map
(fun c
->
1101 if !(c
.was_modified
)
1103 let file = Common.new_temp_file
"cocci_small_output" ".c" in
1105 [(c
.ast_c
, (c
.fullstring
, c
.tokens_c
)), Unparse_c.PPnormal
]
1108 (* Common.command2 ("cat " ^ file); *)
1109 let cprogram = cprogram_of_file c
.all_typedefs c
.all_macros
file in
1110 let xs = build_info_program cprogram c
.env_typing_before
in
1112 (* TODO: assert env has not changed,
1113 * if yes then must also reparse what follows even if not modified.
1114 * Do that only if contain_typedmetavar of course, so good opti.
1116 (* Common.list_init xs *) (* get rid of the FinalDef *)
1122 let rebuild_info_c_and_headers ccs isexp
=
1123 ccs
+> List.iter
(fun c_or_h
->
1124 if c_or_h
.asts
+> List.exists
(fun c
-> !(c
.was_modified
))
1125 then c_or_h
.was_modified_once
:= true;
1127 ccs
+> List.map
(fun c_or_h
->
1130 rebuild_info_program c_or_h
.asts c_or_h
.full_fname isexp
}
1133 let rec prepare_h seen env hpath choose_includes
: file_info list
=
1134 if not
(Common.lfile_exists hpath
)
1137 pr2_once
("TYPE: header " ^ hpath ^
" not found");
1142 let h_cs = cprogram_of_file_cached hpath
in
1143 let local_includes =
1144 if choose_includes
=*= Flag_cocci.I_REALLY_ALL_INCLUDES
1147 (function x
-> not
(List.mem x
!seen))
1148 (includes_to_parse
[(hpath
,h_cs)] choose_includes
)
1150 seen := local_includes @ !seen;
1153 (List.map
(function x
-> prepare_h seen env x choose_includes
)
1155 let info_h_cs = build_info_program h_cs !env
in
1159 else last_env_toplevel_c_info info_h_cs;
1162 fname
= Common.basename hpath
;
1165 was_modified_once
= ref false;
1171 let prepare_c files choose_includes
: file_info list
=
1172 let cprograms = List.map
cprogram_of_file_cached files
in
1173 let includes = includes_to_parse
(zip files
cprograms) choose_includes
in
1174 let seen = ref includes in
1176 (* todo?: may not be good to first have all the headers and then all the c *)
1177 let env = ref !TAC.initial_env
in
1181 List.map
(function hpath
-> prepare_h seen env hpath choose_includes
) +>
1185 (zip files
cprograms) +>
1187 (function (file, cprogram) ->
1188 (* todo?: don't update env ? *)
1189 let cs = build_info_program cprogram !env in
1190 (* we do that only for the c, not for the h *)
1191 ignore
(update_include_rel_pos (cs +> List.map
(fun x
-> x
.ast_c
)));
1193 fname
= Common.basename
file;
1196 was_modified_once
= ref false;
1203 (*****************************************************************************)
1204 (* Manage environments as they are being built up *)
1205 (*****************************************************************************)
1207 let init_env _ = Hashtbl.create
101
1209 let update_env env v i
= Hashtbl.replace
env v i
; env
1211 (* know that there are no conflicts *)
1212 let safe_update_env env v i
= Hashtbl.add
env v i
; env
1215 List.sort compare
(Hashtbl.fold
(fun k v rest
-> (k
,v
) :: rest
) env [])
1217 (*****************************************************************************)
1218 (* Processing the ctls and toplevel C elements *)
1219 (*****************************************************************************)
1221 (* The main algorithm =~
1222 * The algorithm is roughly:
1223 * for_all ctl rules in SP
1224 * for_all minirule in rule (no more)
1225 * for_all binding (computed during previous phase)
1226 * for_all C elements
1227 * match control flow of function vs minirule
1228 * with the binding and update the set of possible
1229 * bindings, and returned the possibly modified function.
1230 * pretty print modified C elements and reparse it.
1233 * On ne prends que les newbinding ou returned_any_state est vrai.
1234 * Si ca ne donne rien, on prends ce qu'il y avait au depart.
1235 * Mais au nouveau depart de quoi ?
1236 * - si ca donne rien apres avoir traité toutes les fonctions avec ce binding ?
1237 * - ou alors si ca donne rien, apres avoir traité toutes les fonctions
1238 * avec tous les bindings du round d'avant ?
1240 * Julia pense qu'il faut prendre la premiere solution.
1241 * Example: on a deux environnements candidats, E1 et E2 apres avoir traité
1242 * la regle ctl 1. On arrive sur la regle ctl 2.
1243 * E1 ne donne rien pour la regle 2, on garde quand meme E1 pour la regle 3.
1244 * E2 donne un match a un endroit et rend E2' alors on utilise ca pour
1247 * I have not to look at used_after_list to decide to restart from
1248 * scratch. I just need to look if the binding list is empty.
1249 * Indeed, let's suppose that a SP have 3 regions/rules. If we
1250 * don't find a match for the first region, then if this first
1251 * region does not bind metavariable used after, that is if
1252 * used_after_list is empty, then mysat(), even if does not find a
1253 * match, will return a Left, with an empty transformation_info,
1254 * and so current_binding will grow. On the contrary if the first
1255 * region must bind some metavariables used after, and that we
1256 * dont find any such region, then mysat() will returns lots of
1257 * Right, and current_binding will not grow, and so we will have
1258 * an empty list of binding, and we will catch such a case.
1260 * opti: julia says that because the binding is
1261 * determined by the used_after_list, the items in the list
1262 * are kind of sorted, so could optimise the insert_set operations.
1266 (* r(ule), c(element in C code), e(nvironment) *)
1268 let merge_env new_e old_e
=
1270 (function (e
,rules
) ->
1271 let _ = update_env old_e e rules
in ()) new_e
;
1274 let contains_binding e
(_,(r,m
),_) =
1276 let _ = List.find
(function ((re
, rm
), _) -> r =*= re
&& m
=$
= rm
) e
in
1278 with Not_found
-> false
1282 let python_application mv ve script_vars
r =
1286 ((Some x
,None
),y
,z
) -> (x
,y
,z
)
1289 (Printf.sprintf
"unexpected ast metavar in rule %s"
1290 r.scr_rule_info
.rulename
))
1293 Pycocci.build_classes
(List.map
(function (x
,y
) -> x
) ve
);
1294 Pycocci.construct_variables
mv ve
;
1295 Pycocci.construct_script_variables script_vars
;
1296 let _ = Pycocci.pyrun_simplestring
(local_python_code ^
r.script_code
) in
1299 else if !Pycocci.inc_match
1300 then Some
(Pycocci.retrieve_script_variables script_vars
)
1302 with Pycocci.Pycocciexception
->
1303 (pr2
("Failure in " ^
r.scr_rule_info
.rulename
);
1304 raise
Pycocci.Pycocciexception
)
1306 let ocaml_application mv ve script_vars
r =
1309 Run_ocamlcocci.run
mv ve script_vars
1310 r.scr_rule_info
.rulename
r.script_code
in
1313 else if !Coccilib.inc_match
1314 then Some
script_vals
1316 with e
-> (pr2
("Failure in " ^
r.scr_rule_info
.rulename
); raise e
)
1318 (* returns Left in case of dependency failure, Right otherwise *)
1319 let apply_script_rule r cache newes e rules_that_have_matched
1320 rules_that_have_ever_matched script_application
=
1321 Common.profile_code
r.language
(fun () ->
1322 show_or_not_scr_rule_name r.scr_rule_info
.ruleid
;
1323 if not
(interpret_dependencies rules_that_have_matched
1324 !rules_that_have_ever_matched
r.scr_rule_info
.dependencies
)
1327 print_dependencies "dependencies for script not satisfied:"
1328 rules_that_have_matched
1329 !rules_that_have_ever_matched
r.scr_rule_info
.dependencies
;
1330 show_or_not_binding "in environment" e
;
1331 (cache
, safe_update_env newes e rules_that_have_matched
)
1335 let (_, mv, script_vars
, _) = r.scr_ast_rule
in
1337 (List.map
(function (n
,v
) -> (("virtual",n
),Ast_c.MetaIdVal
(v
,[])))
1338 !Flag.defined_virtual_env
) @ e
in
1339 let not_bound x
= not
(contains_binding ve x
) in
1340 (match List.filter
not_bound mv with
1342 let relevant_bindings =
1344 (function ((re
,rm
),_) ->
1345 List.exists
(function (_,(r,m
),_) -> r =*= re
&& m
=$
= rm
) mv)
1348 match List.assoc
relevant_bindings cache
with
1349 None
-> (cache
,newes
)
1350 | Some
script_vals ->
1352 "dependencies for script satisfied, but cached:"
1353 rules_that_have_matched
1354 !rules_that_have_ever_matched
1355 r.scr_rule_info
.dependencies
;
1356 show_or_not_binding "in" e
;
1357 (* env might be bigger than what was cached against, so have to
1358 merge with newes anyway *)
1359 let new_e = (List.combine script_vars
script_vals) @ e
in
1363 (fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1364 (cache
,update_env newes
new_e rules_that_have_matched
)
1367 print_dependencies "dependencies for script satisfied:"
1368 rules_that_have_matched
1369 !rules_that_have_ever_matched
1370 r.scr_rule_info
.dependencies
;
1371 show_or_not_binding "in" e
;
1372 match script_application
mv ve script_vars
r with
1374 (* failure means we should drop e, no new bindings *)
1375 (((relevant_bindings,None
) :: cache
), newes
)
1376 | Some
script_vals ->
1378 List.map
(function x
-> Ast_c.MetaIdVal
(x
,[]))
1380 let new_e = (List.combine script_vars
script_vals) @ e
in
1384 (fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1385 r.scr_rule_info
.was_matched
:= true;
1386 (((relevant_bindings,Some
script_vals) :: cache
),
1387 update_env newes
new_e
1388 (r.scr_rule_info
.rulename
:: rules_that_have_matched
))
1391 (if !Flag_cocci.show_dependencies
1393 let m2c (_,(r,x
),_) = r^
"."^x
in
1394 pr2
(Printf.sprintf
"script not applied: %s not bound"
1395 (String.concat
", " (List.map
m2c unbound
))));
1398 List.filter
(fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1399 (cache
, update_env newes
e rules_that_have_matched
))
1402 let rec apply_cocci_rule r rules_that_have_ever_matched es
1403 (ccs
:file_info list
ref) =
1404 Common.profile_code
r.rule_info
.rulename
(fun () ->
1405 show_or_not_rule_name r.ast_rule
r.rule_info
.ruleid
;
1406 show_or_not_ctl_text r.ctl
r.ast_rule
r.rule_info
.ruleid
;
1408 let reorganized_env =
1409 reassociate_positions
r.free_vars
r.negated_pos_vars
!es
in
1411 (* looping over the environments *)
1412 let (_,newes
(* envs for next round/rule *)) =
1414 (function (cache
,newes
) ->
1415 function ((e,rules_that_have_matched
),relevant_bindings) ->
1416 if not
(interpret_dependencies rules_that_have_matched
1417 !rules_that_have_ever_matched
1418 r.rule_info
.dependencies
)
1422 ("dependencies for rule "^
r.rule_info
.rulename^
1424 rules_that_have_matched
1425 !rules_that_have_ever_matched
r.rule_info
.dependencies
;
1426 show_or_not_binding "in environment" e;
1431 (fun (s,v
) -> List.mem
s r.rule_info
.used_after
))
1432 rules_that_have_matched
)
1436 try List.assoc
relevant_bindings cache
1440 ("dependencies for rule "^
r.rule_info
.rulename^
1442 rules_that_have_matched
1443 !rules_that_have_ever_matched
1444 r.rule_info
.dependencies
;
1445 show_or_not_binding "in" e;
1446 show_or_not_binding "relevant in" relevant_bindings;
1448 (* applying the rule *)
1449 (match r.ruletype
with
1451 (* looping over the functions and toplevel elements in
1454 (concat_headers_and_c !ccs
+>
1455 List.fold_left
(fun children_e
(c
,f) ->
1458 (* does also some side effects on c and r *)
1460 process_a_ctl_a_env_a_toplevel
r
1461 relevant_bindings c
f in
1462 match processed with
1463 | None
-> children_e
1464 | Some newbindings
->
1467 (fun children_e newbinding
->
1468 if List.mem newbinding children_e
1470 else newbinding
:: children_e
)
1474 | Ast_cocci.Generated
->
1475 process_a_generated_a_env_a_toplevel
r
1476 relevant_bindings !ccs
;
1479 let old_bindings_to_keep =
1483 (fun (s,v
) -> List.mem
s r.rule_info
.used_after
)) in
1485 if null
new_bindings
1488 (*use the old bindings, specialized to the used_after_list*)
1489 if !Flag_ctl.partial_match
1492 "Empty list of bindings, I will restart from old env\n";
1493 [(old_bindings_to_keep,rules_that_have_matched
)]
1496 (* combine the new bindings with the old ones, and
1497 specialize to the used_after_list *)
1498 let old_variables = List.map fst
old_bindings_to_keep in
1499 (* have to explicitly discard the inherited variables
1500 because we want the inherited value of the positions
1501 variables not the extended one created by
1502 reassociate_positions. want to reassociate freshly
1503 according to the free variables of each rule. *)
1504 let new_bindings_to_add =
1510 (* see comment before combine_pos *)
1511 (s,Ast_c.MetaPosValList
[]) -> false
1513 List.mem
s r.rule_info
.used_after
&&
1514 not
(List.mem
s old_variables)))) in
1516 (function new_binding_to_add
->
1519 old_bindings_to_keep new_binding_to_add
),
1520 r.rule_info
.rulename
::rules_that_have_matched
))
1521 new_bindings_to_add in
1522 ((relevant_bindings,new_bindings)::cache
,
1523 Common.profile_code
"merge_env" (function _ ->
1524 merge_env new_e newes
)))
1525 ([],init_env()) reorganized_env in (* end iter es *)
1526 if !(r.rule_info
.was_matched
)
1527 then Common.push2
r.rule_info
.rulename rules_that_have_ever_matched
;
1529 es
:= end_env newes
;
1531 (* apply the tagged modifs and reparse *)
1532 if not
!Flag.sgrep_mode2
1533 then ccs
:= rebuild_info_c_and_headers !ccs
r.isexp
)
1535 and reassociate_positions free_vars negated_pos_vars envs
=
1536 (* issues: isolate the bindings that are relevant to a given rule.
1537 separate out the position variables
1538 associate all of the position variables for a given set of relevant
1539 normal variable bindings with each set of relevant normal variable
1540 bindings. Goal: if eg if@p (E) matches in two places, then both inherited
1541 occurrences of E should see both bindings of p, not just its own.
1542 Otherwise, a position constraint for something that matches in two
1543 places will never be useful, because the position can always be
1544 different from the other one. *)
1548 List.filter
(function (x
,_) -> List.mem x free_vars
) e)
1550 let splitted_relevant =
1551 (* separate the relevant variables into the non-position ones and the
1556 (function (non_pos
,pos
) ->
1557 function (v
,_) as x
->
1558 if List.mem v negated_pos_vars
1559 then (non_pos
,x
::pos
)
1560 else (x
::non_pos
,pos
))
1563 let splitted_relevant =
1565 (function (non_pos
,pos
) ->
1566 (List.sort compare non_pos
,List.sort compare pos
))
1567 splitted_relevant in
1570 (function non_pos
->
1572 if List.mem np non_pos
then non_pos
else np
::non_pos
)
1573 [] splitted_relevant in
1574 let extended_relevant =
1575 (* extend the position variables with the values found at other identical
1576 variable bindings *)
1578 (function non_pos
->
1581 (function (other_non_pos
,other_pos
) ->
1582 (* do we want equal? or just somehow compatible? eg non_pos
1583 binds only E, but other_non_pos binds both E and E1 *)
1584 non_pos
=*= other_non_pos
)
1585 splitted_relevant in
1589 (combine_pos negated_pos_vars
1590 (List.map
(function (_,x
) -> x
) others)))))
1593 (List.map
(function (non_pos
,_) -> List.assoc non_pos
extended_relevant)
1596 (* If the negated posvar is not bound at all, this function will
1597 nevertheless bind it to []. If we get rid of these bindings, then the
1598 matching of the term the position variable with the constraints will fail
1599 because some variables are unbound. So we let the binding be [] and then
1600 we will have to clean these up afterwards. This should be the only way
1601 that a position variable can have an empty binding. *)
1602 and combine_pos negated_pos_vars
others =
1608 (function positions ->
1609 function other_list
->
1611 match List.assoc posvar other_list
with
1612 Ast_c.MetaPosValList l1
->
1613 Common.union_set l1
positions
1614 | _ -> failwith
"bad value for a position variable"
1615 with Not_found
-> positions)
1617 (posvar
,Ast_c.MetaPosValList
positions))
1620 and process_a_generated_a_env_a_toplevel2
r env = function
1625 (rule
,_) when rule
=$
= r.rule_info
.rulename
-> false
1626 | (_,"ARGS") -> false
1629 let env_domain = List.map
(function (nm
,vl
) -> nm
) env in
1633 let (rl
,_) = Ast_cocci.get_meta_name md
in rl
=$
= r.rule_info
.rulename
)
1635 if Common.include_set
free_vars env_domain
1636 then Unparse_hrule.pp_rule
metavars r.ast_rule
env cfile.full_fname
1637 | _ -> failwith
"multiple files not supported"
1639 and process_a_generated_a_env_a_toplevel rule
env ccs
=
1640 Common.profile_code
"process_a_ctl_a_env_a_toplevel"
1641 (fun () -> process_a_generated_a_env_a_toplevel2 rule
env ccs
)
1643 (* does side effects on C ast and on Cocci info rule *)
1644 and process_a_ctl_a_env_a_toplevel2
r e c
f =
1645 indent_do
(fun () ->
1646 show_or_not_celem "trying" c
.ast_c
;
1647 Flag.currentfile
:= Some
(f ^
":" ^
get_celem c
.ast_c
);
1648 match (r.ctl
,c
.ast_c
) with
1649 ((Asttoctl2.NONDECL ctl
,t
),Ast_c.Declaration
_) -> None
1650 | ((Asttoctl2.NONDECL ctl
,t
), _)
1651 | ((Asttoctl2.CODE ctl
,t
), _) ->
1652 let ctl = (ctl,t
) in (* ctl and other info *)
1653 let (trans_info, returned_any_states
, inherited_bindings
, newbindings
) =
1654 Common.save_excursion
Flag_ctl.loop_in_src_code
(fun () ->
1655 Flag_ctl.loop_in_src_code
:=
1656 !Flag_ctl.loop_in_src_code
||c
.contain_loop;
1658 (***************************************)
1659 (* !Main point! The call to the engine *)
1660 (***************************************)
1662 CCI.model_for_ctl
r.dropped_isos
(Common.some c
.flow) e
1663 in CCI.mysat
model_ctl ctl
1664 (r.rule_info
.rulename
, r.rule_info
.used_after
, e))
1666 if not returned_any_states
1670 show_or_not_celem "found match in" c
.ast_c
;
1671 show_or_not_trans_info trans_info;
1672 List.iter
(show_or_not_binding "out") newbindings
;
1674 r.rule_info
.was_matched
:= true;
1676 if not
(null
trans_info) &&
1677 not
(!Flag.sgrep_mode2
&& not
!Flag_cocci.show_diff
)
1680 c
.was_modified
:= true;
1682 (* les "more than one var in a decl" et "already tagged token"
1683 * font crasher coccinelle. Si on a 5 fichiers, donc on a 5
1684 * failed. Le try limite le scope des crashes pendant la
1685 * trasformation au fichier concerne. *)
1687 (* modify ast via side effect *)
1689 (Transformation_c.transform
r.rule_info
.rulename
1691 inherited_bindings
trans_info (Common.some c
.flow));
1692 with Timeout
-> raise Timeout
| UnixExit i
-> raise
(UnixExit i
)
1695 Some
(List.map
(function x
-> x
@inherited_bindings
) newbindings
)
1699 and process_a_ctl_a_env_a_toplevel a b c
f=
1700 Common.profile_code
"process_a_ctl_a_env_a_toplevel"
1701 (fun () -> process_a_ctl_a_env_a_toplevel2 a b c
f)
1704 let rec bigloop2 rs
(ccs
: file_info list
) =
1705 let init_es = [(Ast_c.emptyMetavarsBinding
,[])] in
1706 let es = ref init_es in
1707 let ccs = ref ccs in
1708 let rules_that_have_ever_matched = ref [] in
1712 (* looping over the rules *)
1713 rs
+> List.iter
(fun r ->
1715 InitialScriptRuleCocciInfo
r | FinalScriptRuleCocciInfo
r -> ()
1716 | ScriptRuleCocciInfo
r ->
1717 if !Flag_cocci.show_ctl_text
then begin
1718 Common.pr_xxxxxxxxxxxxxxxxx
();
1719 pr
("script: " ^
r.language
);
1720 Common.pr_xxxxxxxxxxxxxxxxx
();
1722 adjust_pp_with_indent
(fun () ->
1723 Format.force_newline
();
1724 let (l,mv,script_vars
,code
) = r.scr_ast_rule
in
1725 let nm = r.scr_rule_info
.rulename
in
1726 let deps = r.scr_rule_info
.dependencies
in
1727 Pretty_print_cocci.unparse
1728 (Ast_cocci.ScriptRule
(nm,l,deps,mv,script_vars
,code
)));
1731 (*pr2 (List.hd(cmd_to_list "free -m | grep Mem"));*)
1732 if !Flag.show_misc
then print_endline
"RESULT =";
1736 (function (cache
, newes
) ->
1737 function (e, rules_that_have_matched
) ->
1738 match r.language
with
1740 apply_script_rule r cache newes
e rules_that_have_matched
1741 rules_that_have_ever_matched python_application
1743 apply_script_rule r cache newes
e rules_that_have_matched
1744 rules_that_have_ever_matched ocaml_application
1746 concat_headers_and_c !ccs +> List.iter
(fun (c
,_) ->
1749 Printf.printf
"Flow: %s\r\nFlow!\r\n%!" c
.fullstring
);
1752 Printf.printf
"Unknown language: %s\n" r.language
;
1754 ([],init_env()) !es in
1756 (if !(r.scr_rule_info
.was_matched
)
1758 Common.push2
r.scr_rule_info
.rulename
rules_that_have_ever_matched);
1760 (* just newes can't work, because if one does include_match false
1761 on everything that binds a variable, then nothing is left *)
1763 (if Hashtbl.length newes
= 0 then init_es else end_env newes
)
1764 | CocciRuleCocciInfo
r ->
1765 apply_cocci_rule r rules_that_have_ever_matched
1769 if !Flag.sgrep_mode2
1771 (* sgrep can lead to code that is not parsable, but we must
1772 * still call rebuild_info_c_and_headers to pretty print the
1773 * action (MINUS), so that later the diff will show what was
1774 * matched by sgrep. But we don't want the parsing error message
1775 * hence the following flag setting. So this code propably
1776 * will generate a NotParsedCorrectly for the matched parts
1777 * and the very final pretty print and diff will work
1779 Flag_parsing_c.verbose_parsing
:= false;
1780 ccs := rebuild_info_c_and_headers !ccs false
1782 !ccs (* return final C asts *)
1785 Common.profile_code
"bigloop" (fun () -> bigloop2 a b
)
1787 type init_final
= Initial
| Final
1789 let initial_final_bigloop2 ty rebuild
r =
1790 if !Flag_cocci.show_ctl_text
then
1792 Common.pr_xxxxxxxxxxxxxxxxx
();
1793 pr
((match ty
with Initial
-> "initial" | Final
-> "final") ^
": " ^
1795 Common.pr_xxxxxxxxxxxxxxxxx
();
1797 adjust_pp_with_indent
(fun () ->
1798 Format.force_newline
();
1799 Pretty_print_cocci.unparse
(rebuild
r.scr_ast_rule
r.scr_rule_info
.dependencies
));
1802 match r.language
with
1804 (* include_match makes no sense in an initial or final rule, although
1805 we have no way to prevent it *)
1806 let newes = init_env() in
1807 let _ = apply_script_rule r [] newes [] [] (ref []) python_application in
1809 | "ocaml" when ty
= Initial
-> () (* nothing to do *)
1811 (* include_match makes no sense in an initial or final rule, although
1812 we have no way to prevent it *)
1813 let newes = init_env() in
1814 let _ = apply_script_rule r [] newes [] [] (ref []) ocaml_application in
1817 failwith
("Unknown language for initial/final script: "^
1820 let initial_final_bigloop a b c
=
1821 Common.profile_code
"initial_final_bigloop"
1822 (fun () -> initial_final_bigloop2 a b c
)
1824 (*****************************************************************************)
1825 (* The main functions *)
1826 (*****************************************************************************)
1828 let pre_engine2 (coccifile
, isofile
) =
1829 show_or_not_cocci coccifile isofile
;
1830 Pycocci.set_coccifile coccifile
;
1833 if not
(Common.lfile_exists
isofile)
1835 pr2
("warning: Can't find default iso file: " ^
isofile);
1838 else Some
isofile in
1840 (* useful opti when use -dir *)
1841 let (metavars,astcocci
,
1842 free_var_lists
,negated_pos_lists
,used_after_lists
,
1843 positions_lists
,(toks
,_,_)) = sp_of_file coccifile
isofile in
1845 let ctls = ctls_of_ast astcocci used_after_lists positions_lists
in
1847 g_contain_typedmetavar := sp_contain_typed_metavar astcocci
;
1849 check_macro_in_sp_and_adjust toks
;
1851 show_or_not_ctl_tex astcocci
ctls;
1854 prepare_cocci ctls free_var_lists negated_pos_lists
1855 used_after_lists positions_lists
metavars astcocci
in
1857 let used_languages =
1859 (function languages
->
1861 ScriptRuleCocciInfo
(r) ->
1862 if List.mem
r.language languages
then
1865 r.language
::languages
1870 let rlang = r.language
in
1871 let rname = r.scr_rule_info
.rulename
in
1873 let _ = List.assoc
(rlang,rname) !Iteration.initialization_stack
in
1877 Iteration.initialization_stack
:=
1878 ((rlang,rname),!Flag.defined_virtual_rules
) ::
1879 !Iteration.initialization_stack
;
1880 initial_final_bigloop Initial
1881 (fun (x
,_,_,y
) -> fun deps ->
1882 Ast_cocci.InitialScriptRule
(rname,x
,deps,y
))
1886 let initialized_languages =
1888 (function languages
->
1890 InitialScriptRuleCocciInfo
(r) ->
1891 let rlang = r.language
in
1892 (if List.mem
rlang languages
1893 then failwith
("double initializer found for "^
rlang));
1894 if interpret_dependencies [] [] r.scr_rule_info
.dependencies
1895 then begin runrule r; rlang::languages
end
1900 let uninitialized_languages =
1902 (fun used
-> not
(List.mem used
initialized_languages))
1909 dependencies
= Ast_cocci.NoDep
;
1912 was_matched
= ref false;} in
1913 runrule (make_init lgg
"" rule_info))
1914 uninitialized_languages;
1919 Common.profile_code
"pre_engine" (fun () -> pre_engine2 a
)
1921 let full_engine2 (cocci_infos,toks
) cfiles =
1923 show_or_not_cfiles cfiles;
1925 (* optimisation allowing to launch coccinelle on all the drivers *)
1926 if !Flag_cocci.worth_trying_opt
&& not
(worth_trying cfiles toks
)
1932 pr2
("No matches found for " ^
(Common.join
" " toks
)
1933 ^
"\nSkipping:" ^
(Common.join
" " cfiles)));
1934 cfiles +> List.map
(fun s -> s, None
)
1939 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1940 if !Flag.show_misc
then pr
"let's go";
1941 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1943 if !Flag_cocci.show_binding_in_out
1946 (match !Flag.defined_virtual_rules
with
1948 | l -> pr
(Printf.sprintf
"Defined virtual rules: %s"
1949 (String.concat
" " l)));
1952 pr
(Printf.sprintf
"%s = %s" v vl
))
1953 !Flag.defined_virtual_env
;
1954 Common.pr_xxxxxxxxxxxxxxxxx
()
1957 let choose_includes =
1958 match !Flag_cocci.include_options
with
1959 Flag_cocci.I_UNSPECIFIED
->
1960 if !g_contain_typedmetavar
1961 then Flag_cocci.I_NORMAL_INCLUDES
1962 else Flag_cocci.I_NO_INCLUDES
1964 let c_infos = prepare_c cfiles choose_includes in
1966 (* ! the big loop ! *)
1967 let c_infos'
= bigloop cocci_infos c_infos in
1969 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1970 if !Flag.show_misc
then pr
"Finished";
1971 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1972 if !Flag_ctl.graphical_trace
then gen_pdf_graph ();
1974 c_infos'
+> List.map
(fun c_or_h
->
1975 if !(c_or_h
.was_modified_once
)
1979 Common.new_temp_file
"cocci-output" ("-" ^ c_or_h
.fname
) in
1981 if c_or_h
.fkind
=*= Header
1982 then pr2
("a header file was modified: " ^ c_or_h
.fname
);
1984 (* and now unparse everything *)
1985 cfile_of_program (for_unparser c_or_h
.asts
) outfile;
1987 show_or_not_diff c_or_h
.fpath
outfile;
1990 if !Flag.sgrep_mode2
then None
else Some
outfile)
1992 else (c_or_h
.fpath
, None
))
1995 let full_engine a b
=
1996 Common.profile_code
"full_engine"
1997 (fun () -> let res = full_engine2 a b
in (*Gc.print_stat stderr; *)res)
1999 let post_engine2 (cocci_infos,_) =
2001 (function ((language
,_),virt_rules
) ->
2002 Flag.defined_virtual_rules
:= virt_rules
;
2005 (function languages
->
2007 FinalScriptRuleCocciInfo
(r) ->
2008 (if r.language
= language
&& List.mem
r.language languages
2009 then failwith
("double finalizer found for "^
r.language
));
2010 initial_final_bigloop Final
2011 (fun (x
,_,_,y
) -> fun deps ->
2012 Ast_cocci.FinalScriptRule
(r.scr_rule_info
.rulename
,
2015 r.language
::languages
2019 !Iteration.initialization_stack
2022 Common.profile_code
"post_engine" (fun () -> post_engine2 a
)
2024 (*****************************************************************************)
2025 (* check duplicate from result of full_engine *)
2026 (*****************************************************************************)
2028 let check_duplicate_modif2 xs =
2029 (* opti: let groups = Common.groupBy (fun (a,resa) (b,resb) -> a =$= b) xs *)
2030 if !Flag_cocci.verbose_cocci
2031 then pr2
("Check duplication for " ^ i_to_s
(List.length
xs) ^
" files");
2033 let groups = Common.group_assoc_bykey_eff
xs in
2034 groups +> Common.map_filter
(fun (file, xs) ->
2036 | [] -> raise Impossible
2037 | [res] -> Some
(file, res)
2041 if not
(List.for_all
(fun res2
-> res2
=*= None
) xs)
2043 pr2
("different modification result for " ^
file);
2046 else Some
(file, None
)
2048 if not
(List.for_all
(fun res2
->
2052 let diff = Common.cmd_to_list
("diff -u -b -B "^
res^
" "^res2
)
2056 pr2
("different modification result for " ^
file);
2059 else Some
(file, Some
res)
2061 let check_duplicate_modif a
=
2062 Common.profile_code
"check_duplicate" (fun () -> check_duplicate_modif2 a
)