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
-> !Flag_cocci.extra_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
707 (!Flag_cocci.extra_includes
@(List.rev x
)))))(*uniq keeps last*)
709 let rec interpret_dependencies local global
= function
710 Ast_cocci.Dep
s -> List.mem
s local
711 | Ast_cocci.AntiDep
s ->
712 (if !Flag_ctl.steps
!= None
713 then failwith
"steps and ! dependency incompatible");
714 not
(List.mem
s local
)
715 | Ast_cocci.EverDep
s -> List.mem
s global
716 | Ast_cocci.NeverDep
s ->
717 (if !Flag_ctl.steps
!= None
718 then failwith
"steps and ! dependency incompatible");
719 not
(List.mem
s global
)
720 | Ast_cocci.AndDep
(s1
,s2
) ->
721 (interpret_dependencies local global s1
) &&
722 (interpret_dependencies local global s2
)
723 | Ast_cocci.OrDep
(s1
,s2
) ->
724 (interpret_dependencies local global s1
) or
725 (interpret_dependencies local global s2
)
726 | Ast_cocci.NoDep
-> true
727 | Ast_cocci.FailDep
-> false
729 let rec print_dependencies str local global dep
=
730 if !Flag_cocci.show_dependencies
735 let rec loop = function
736 Ast_cocci.Dep
s | Ast_cocci.AntiDep
s ->
737 if not
(List.mem
s !seen)
741 then pr2
(s^
" satisfied")
742 else pr2
(s^
" not satisfied");
745 | Ast_cocci.EverDep
s | Ast_cocci.NeverDep
s ->
746 if not
(List.mem
s !seen)
750 then pr2
(s^
" satisfied")
751 else pr2
(s^
" not satisfied");
754 | Ast_cocci.AndDep
(s1
,s2
) ->
757 | Ast_cocci.OrDep
(s1
,s2
) ->
760 | Ast_cocci.NoDep
-> ()
761 | Ast_cocci.FailDep
-> pr2
"False not satisfied" in
765 (* --------------------------------------------------------------------- *)
766 (* #include relative position in the file *)
767 (* --------------------------------------------------------------------- *)
769 (* compute the set of new prefixes
771 * "a/b/x"; (* in fact it is now a list of string so ["a";"b";"x"] *)
775 * it would give
for the first element
776 * ""; "a"; "a/b"; "a/b/x"
780 * update
: if the
include is inside a ifdef a put nothing
. cf
-test incl
.
781 * this is because we dont want code added inside ifdef
.
784 let compute_new_prefixes xs =
785 xs +> Common.map_withenv
(fun already
xs ->
786 let subdirs_prefixes = Common.inits
xs in
787 let new_first = subdirs_prefixes +> List.filter
(fun x
->
788 not
(List.mem x already
)
797 (* does via side effect on the ref in the Include in Ast_c *)
798 let rec update_include_rel_pos cs
=
799 let only_include = cs
+> Common.map_filter
(fun c
->
801 | Ast_c.CppTop
(Ast_c.Include
{Ast_c.i_include
= ((x
,_));
803 i_is_in_ifdef
= inifdef
}) ->
805 | Ast_c.Weird
_ -> None
814 let (locals
, nonlocals
) =
815 only_include +> Common.partition_either
(fun (c
, aref
) ->
817 | Ast_c.Local x
-> Left
(x
, aref
)
818 | Ast_c.NonLocal x
-> Right
(x
, aref
)
819 | Ast_c.Weird x
-> raise
(Impossible
161)
822 update_rel_pos_bis locals
;
823 update_rel_pos_bis nonlocals
;
825 and update_rel_pos_bis
xs =
826 let xs'
= List.map fst
xs in
827 let the_first = compute_new_prefixes xs'
in
828 let the_last = List.rev
(compute_new_prefixes (List.rev
xs'
)) in
829 let merged = Common.zip
xs (Common.zip
the_first the_last) in
830 merged +> List.iter
(fun ((x
, aref
), (the_first, the_last)) ->
833 Ast_c.first_of
= the_first;
834 Ast_c.last_of
= the_last;
839 (*****************************************************************************)
840 (* All the information needed around the C elements and Cocci rules *)
841 (*****************************************************************************)
843 type toplevel_c_info
= {
844 ast_c
: Ast_c.toplevel
; (* contain refs so can be modified *)
845 tokens_c
: Parser_c.token list
;
848 flow
: Control_flow_c.cflow
option; (* it's the "fixed" flow *)
851 env_typing_before
: TAC.environment
;
852 env_typing_after
: TAC.environment
;
854 was_modified
: bool ref;
856 all_typedefs
: (string, Lexer_parser.identkind
) Common.scoped_h_env
;
857 all_macros
: (string, Cpp_token_c.define_def
) Hashtbl.t
;
864 dependencies
: Ast_cocci.dependency
;
865 used_after
: Ast_cocci.meta_name list
;
867 was_matched
: bool ref;
870 type toplevel_cocci_info_script_rule
= {
873 (Ast_cocci.script_meta_name
* Ast_cocci.meta_name
*
874 Ast_cocci.metavar
) list
*
875 Ast_cocci.meta_name list
(*fresh vars*) *
879 scr_rule_info
: rule_info
;
882 type toplevel_cocci_info_cocci_rule
= {
883 ctl
: Asttoctl2.top_formula
* (CCI.pred list list
);
884 metavars
: Ast_cocci.metavar list
;
885 ast_rule
: Ast_cocci.rule
;
886 isexp
: bool; (* true if + code is an exp, only for Flag.make_hrule *)
888 (* There are also some hardcoded rule names in parse_cocci.ml:
889 * let reserved_names = ["all";"optional_storage";"optional_qualifier"]
891 dropped_isos
: string list
;
892 free_vars
: Ast_cocci.meta_name list
;
893 negated_pos_vars
: Ast_cocci.meta_name list
;
894 positions
: Ast_cocci.meta_name list
;
896 ruletype
: Ast_cocci.ruletype
;
898 rule_info
: rule_info
;
901 type toplevel_cocci_info
=
902 ScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
903 | InitialScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
904 | FinalScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
905 | CocciRuleCocciInfo
of toplevel_cocci_info_cocci_rule
907 type cocci_info
= toplevel_cocci_info list
* string list
option (* tokens *)
909 type kind_file
= Header
| Source
913 was_modified_once
: bool ref;
914 asts
: toplevel_c_info list
;
919 let g_contain_typedmetavar = ref false
922 let last_env_toplevel_c_info xs =
923 (Common.last
xs).env_typing_after
925 let concat_headers_and_c (ccs
: file_info list
)
926 : (toplevel_c_info
* string) list
=
927 (List.concat
(ccs
+> List.map
(fun x
->
928 x
.asts
+> List.map
(fun x'
->
931 let for_unparser xs =
932 xs +> List.map
(fun x
->
933 (x
.ast_c
, (x
.fullstring
, x
.tokens_c
)), Unparse_c.PPviastr
936 let gen_pdf_graph () =
937 (Ctl_engine.get_graph_files
()) +> List.iter
(fun outfile
->
938 Printf.printf
"Generation of %s%!" outfile
;
939 let filename_stack = Ctl_engine.get_graph_comp_files outfile
in
940 List.iter
(fun filename
->
941 ignore
(Unix.system
("dot " ^ filename ^
" -Tpdf -o " ^ filename ^
".pdf;"))
943 let (head
,tail
) = (List.hd
filename_stack, List.tl
filename_stack) in
944 ignore
(Unix.system
("cp " ^ head ^
".pdf " ^ outfile ^
".pdf;"));
945 tail
+> List.iter
(fun filename
->
946 ignore
(Unix.system
("mv " ^ outfile ^
".pdf /tmp/tmp.pdf;"));
947 ignore
(Unix.system
("pdftk " ^ filename ^
".pdf /tmp/tmp.pdf cat output " ^ outfile ^
".pdf"));
949 ignore
(Unix.system
("rm /tmp/tmp.pdf;"));
950 List.iter
(fun filename
->
951 ignore
(Unix.system
("rm " ^ filename ^
" " ^ filename ^
".pdf;"))
953 Printf.printf
" - Done\n")
955 let local_python_code =
956 "from coccinelle import *\n"
959 "import coccinelle\n"^
961 "import coccilib.org\n"^
962 "import coccilib.report\n" ^
966 let make_init lang code rule_info
=
969 scr_ast_rule
= (lang
, mv, [], code
);
971 script_code
= (if lang
= "python" then python_code else "") ^code
;
972 scr_rule_info
= rule_info
;
975 (* --------------------------------------------------------------------- *)
976 let prepare_cocci ctls free_var_lists negated_pos_lists
977 (ua
,fua
,fuas
) positions_list metavars astcocci
=
979 let gathered = Common.index_list_1
980 (zip
(zip
(zip
(zip
(zip
(zip
(zip
(zip
ctls metavars
) astcocci
)
982 negated_pos_lists
) ua
) fua
) fuas
) positions_list
)
985 (fun (((((((((ctl_toplevel_list
,metavars
),ast
),free_var_list
),
986 negated_pos_list
),ua
),fua
),fuas
),positions_list
),rulenb
) ->
988 let build_rule_info rulename deps
=
989 {rulename
= rulename
;
991 used_after
= (List.hd ua
) @ (List.hd fua
);
993 was_matched
= ref false;} in
995 let is_script_rule r
=
997 Ast_cocci.ScriptRule
_
998 | Ast_cocci.InitialScriptRule
_ | Ast_cocci.FinalScriptRule
_ -> true
1001 if not
(List.length ctl_toplevel_list
=|= 1) && not
(is_script_rule ast
)
1002 then failwith
"not handling multiple minirules";
1005 Ast_cocci.ScriptRule
(name,lang
,deps
,mv,script_vars
,code
) ->
1008 scr_ast_rule
= (lang
, mv, script_vars
, code
);
1011 scr_rule_info
= build_rule_info name deps
;
1013 in ScriptRuleCocciInfo
r
1014 | Ast_cocci.InitialScriptRule
(name,lang
,deps
,code
) ->
1015 let r = make_init lang code
(build_rule_info name deps
) in
1016 InitialScriptRuleCocciInfo
r
1017 | Ast_cocci.FinalScriptRule
(name,lang
,deps
,code
) ->
1021 scr_ast_rule
= (lang
, mv, [], code
);
1024 scr_rule_info
= build_rule_info name deps
;
1026 in FinalScriptRuleCocciInfo
r
1027 | Ast_cocci.CocciRule
1028 (rulename
,(dependencies
,dropped_isos
,z
),restast
,isexp
,ruletype
) ->
1029 CocciRuleCocciInfo
(
1031 ctl
= List.hd ctl_toplevel_list
;
1032 metavars
= metavars
;
1034 isexp
= List.hd isexp
;
1035 dropped_isos
= dropped_isos
;
1036 free_vars
= List.hd free_var_list
;
1037 negated_pos_vars
= List.hd negated_pos_list
;
1038 positions
= List.hd positions_list
;
1039 ruletype
= ruletype
;
1040 rule_info
= build_rule_info rulename dependencies
;
1044 (* --------------------------------------------------------------------- *)
1046 let build_info_program (cprogram
,typedefs
,macros
) env
=
1048 let (cs
, parseinfos
) =
1049 Common.unzip cprogram
in
1052 parseinfos
+> List.map
(fun (s,toks
) -> toks
) +> List.flatten
in
1054 (* I use cs' but really annotate_xxx work by doing side effects on cs *)
1056 Comment_annotater_c.annotate_program
alltoks cs in
1059 Type_annoter_c.annotate_program env
(*!g_contain_typedmetavar*) cs'
1062 zip
cs_with_envs parseinfos
+> List.map
(fun ((c
, (enva
,envb
)), parseinfo
)->
1063 let (fullstr
, tokens) = parseinfo
in
1066 ast_to_flow_with_error_messages c
+>
1067 Common.map_option
(fun flow ->
1068 let flow = Ast_to_flow.annotate_loop_nodes
flow in
1070 (* remove the fake nodes for julia *)
1071 let fixed_flow = CCI.fix_flow_ctl
flow in
1073 if !Flag_cocci.show_flow
then print_flow fixed_flow;
1074 if !Flag_cocci.show_before_fixed_flow
then print_flow flow;
1080 ast_c
= c
; (* contain refs so can be modified *)
1082 fullstring
= fullstr
;
1086 contain_loop = contain_loop flow;
1088 env_typing_before
= enva
;
1089 env_typing_after
= envb
;
1091 was_modified
= ref false;
1093 all_typedefs
= typedefs
;
1094 all_macros
= macros
;
1099 (* Optimisation. Try not unparse/reparse the whole file when have modifs *)
1100 let rebuild_info_program cs file isexp
=
1101 cs +> List.map
(fun c
->
1102 if !(c
.was_modified
)
1104 let file = Common.new_temp_file
"cocci_small_output" ".c" in
1106 [(c
.ast_c
, (c
.fullstring
, c
.tokens_c
)), Unparse_c.PPnormal
]
1109 (* Common.command2 ("cat " ^ file); *)
1110 let cprogram = cprogram_of_file c
.all_typedefs c
.all_macros
file in
1111 let xs = build_info_program cprogram c
.env_typing_before
in
1113 (* TODO: assert env has not changed,
1114 * if yes then must also reparse what follows even if not modified.
1115 * Do that only if contain_typedmetavar of course, so good opti.
1117 (* Common.list_init xs *) (* get rid of the FinalDef *)
1123 let rebuild_info_c_and_headers ccs isexp
=
1124 ccs
+> List.iter
(fun c_or_h
->
1125 if c_or_h
.asts
+> List.exists
(fun c
-> !(c
.was_modified
))
1126 then c_or_h
.was_modified_once
:= true;
1128 ccs
+> List.map
(fun c_or_h
->
1131 rebuild_info_program c_or_h
.asts c_or_h
.full_fname isexp
}
1134 let rec prepare_h seen env hpath choose_includes
: file_info list
=
1135 if not
(Common.lfile_exists hpath
)
1138 pr2_once
("TYPE: header " ^ hpath ^
" not found");
1143 let h_cs = cprogram_of_file_cached hpath
in
1144 let local_includes =
1145 if choose_includes
=*= Flag_cocci.I_REALLY_ALL_INCLUDES
1148 (function x
-> not
(List.mem x
!seen))
1149 (includes_to_parse
[(hpath
,h_cs)] choose_includes
)
1151 seen := local_includes @ !seen;
1154 (List.map
(function x
-> prepare_h seen env x choose_includes
)
1156 let info_h_cs = build_info_program h_cs !env
in
1160 else last_env_toplevel_c_info info_h_cs;
1163 fname
= Common.basename hpath
;
1166 was_modified_once
= ref false;
1172 let prepare_c files choose_includes
: file_info list
=
1173 let cprograms = List.map
cprogram_of_file_cached files
in
1174 let includes = includes_to_parse
(zip files
cprograms) choose_includes
in
1175 let seen = ref includes in
1177 (* todo?: may not be good to first have all the headers and then all the c *)
1178 let env = ref !TAC.initial_env
in
1182 List.map
(function hpath
-> prepare_h seen env hpath choose_includes
) +>
1186 (zip files
cprograms) +>
1188 (function (file, cprogram) ->
1189 (* todo?: don't update env ? *)
1190 let cs = build_info_program cprogram !env in
1191 (* we do that only for the c, not for the h *)
1192 ignore
(update_include_rel_pos (cs +> List.map
(fun x
-> x
.ast_c
)));
1194 fname
= Common.basename
file;
1197 was_modified_once
= ref false;
1204 (*****************************************************************************)
1205 (* Manage environments as they are being built up *)
1206 (*****************************************************************************)
1208 let init_env _ = Hashtbl.create
101
1210 let update_env env v i
= Hashtbl.replace
env v i
; env
1212 (* know that there are no conflicts *)
1213 let safe_update_env env v i
= Hashtbl.add
env v i
; env
1216 List.sort compare
(Hashtbl.fold
(fun k v rest
-> (k
,v
) :: rest
) env [])
1218 (*****************************************************************************)
1219 (* Processing the ctls and toplevel C elements *)
1220 (*****************************************************************************)
1222 (* The main algorithm =~
1223 * The algorithm is roughly:
1224 * for_all ctl rules in SP
1225 * for_all minirule in rule (no more)
1226 * for_all binding (computed during previous phase)
1227 * for_all C elements
1228 * match control flow of function vs minirule
1229 * with the binding and update the set of possible
1230 * bindings, and returned the possibly modified function.
1231 * pretty print modified C elements and reparse it.
1234 * On ne prends que les newbinding ou returned_any_state est vrai.
1235 * Si ca ne donne rien, on prends ce qu'il y avait au depart.
1236 * Mais au nouveau depart de quoi ?
1237 * - si ca donne rien apres avoir traité toutes les fonctions avec ce binding ?
1238 * - ou alors si ca donne rien, apres avoir traité toutes les fonctions
1239 * avec tous les bindings du round d'avant ?
1241 * Julia pense qu'il faut prendre la premiere solution.
1242 * Example: on a deux environnements candidats, E1 et E2 apres avoir traité
1243 * la regle ctl 1. On arrive sur la regle ctl 2.
1244 * E1 ne donne rien pour la regle 2, on garde quand meme E1 pour la regle 3.
1245 * E2 donne un match a un endroit et rend E2' alors on utilise ca pour
1248 * I have not to look at used_after_list to decide to restart from
1249 * scratch. I just need to look if the binding list is empty.
1250 * Indeed, let's suppose that a SP have 3 regions/rules. If we
1251 * don't find a match for the first region, then if this first
1252 * region does not bind metavariable used after, that is if
1253 * used_after_list is empty, then mysat(), even if does not find a
1254 * match, will return a Left, with an empty transformation_info,
1255 * and so current_binding will grow. On the contrary if the first
1256 * region must bind some metavariables used after, and that we
1257 * dont find any such region, then mysat() will returns lots of
1258 * Right, and current_binding will not grow, and so we will have
1259 * an empty list of binding, and we will catch such a case.
1261 * opti: julia says that because the binding is
1262 * determined by the used_after_list, the items in the list
1263 * are kind of sorted, so could optimise the insert_set operations.
1267 (* r(ule), c(element in C code), e(nvironment) *)
1269 let merge_env new_e old_e
=
1271 (function (e
,rules
) ->
1272 let _ = update_env old_e e rules
in ()) new_e
;
1275 let contains_binding e
(_,(r,m
),_) =
1277 let _ = List.find
(function ((re
, rm
), _) -> r =*= re
&& m
=$
= rm
) e
in
1279 with Not_found
-> false
1283 let python_application mv ve script_vars
r =
1287 ((Some x
,None
),y
,z
) -> (x
,y
,z
)
1290 (Printf.sprintf
"unexpected ast metavar in rule %s"
1291 r.scr_rule_info
.rulename
))
1294 Pycocci.build_classes
(List.map
(function (x
,y
) -> x
) ve
);
1295 Pycocci.construct_variables
mv ve
;
1296 Pycocci.construct_script_variables script_vars
;
1297 let _ = Pycocci.pyrun_simplestring
(local_python_code ^
r.script_code
) in
1300 else if !Pycocci.inc_match
1301 then Some
(Pycocci.retrieve_script_variables script_vars
)
1303 with Pycocci.Pycocciexception
->
1304 (pr2
("Failure in " ^
r.scr_rule_info
.rulename
);
1305 raise
Pycocci.Pycocciexception
)
1307 let ocaml_application mv ve script_vars
r =
1310 Run_ocamlcocci.run
mv ve script_vars
1311 r.scr_rule_info
.rulename
r.script_code
in
1314 else if !Coccilib.inc_match
1315 then Some
script_vals
1317 with e
-> (pr2
("Failure in " ^
r.scr_rule_info
.rulename
); raise e
)
1319 (* returns Left in case of dependency failure, Right otherwise *)
1320 let apply_script_rule r cache newes e rules_that_have_matched
1321 rules_that_have_ever_matched script_application
=
1322 Common.profile_code
r.language
(fun () ->
1323 show_or_not_scr_rule_name r.scr_rule_info
.ruleid
;
1324 if not
(interpret_dependencies rules_that_have_matched
1325 !rules_that_have_ever_matched
r.scr_rule_info
.dependencies
)
1328 print_dependencies "dependencies for script not satisfied:"
1329 rules_that_have_matched
1330 !rules_that_have_ever_matched
r.scr_rule_info
.dependencies
;
1331 show_or_not_binding "in environment" e
;
1332 (cache
, safe_update_env newes e rules_that_have_matched
)
1336 let (_, mv, script_vars
, _) = r.scr_ast_rule
in
1338 (List.map
(function (n
,v
) -> (("virtual",n
),Ast_c.MetaIdVal
(v
,[])))
1339 !Flag.defined_virtual_env
) @ e
in
1340 let not_bound x
= not
(contains_binding ve x
) in
1341 (match List.filter
not_bound mv with
1343 let relevant_bindings =
1345 (function ((re
,rm
),_) ->
1346 List.exists
(function (_,(r,m
),_) -> r =*= re
&& m
=$
= rm
) mv)
1349 match List.assoc
relevant_bindings cache
with
1350 None
-> (cache
,newes
)
1351 | Some
script_vals ->
1353 "dependencies for script satisfied, but cached:"
1354 rules_that_have_matched
1355 !rules_that_have_ever_matched
1356 r.scr_rule_info
.dependencies
;
1357 show_or_not_binding "in" e
;
1358 (* env might be bigger than what was cached against, so have to
1359 merge with newes anyway *)
1360 let new_e = (List.combine script_vars
script_vals) @ e
in
1364 (fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1365 (cache
,update_env newes
new_e rules_that_have_matched
)
1368 print_dependencies "dependencies for script satisfied:"
1369 rules_that_have_matched
1370 !rules_that_have_ever_matched
1371 r.scr_rule_info
.dependencies
;
1372 show_or_not_binding "in" e
;
1373 match script_application
mv ve script_vars
r with
1375 (* failure means we should drop e, no new bindings *)
1376 (((relevant_bindings,None
) :: cache
), newes
)
1377 | Some
script_vals ->
1379 List.map
(function x
-> Ast_c.MetaIdVal
(x
,[]))
1381 let new_e = (List.combine script_vars
script_vals) @ e
in
1385 (fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1386 r.scr_rule_info
.was_matched
:= true;
1387 (((relevant_bindings,Some
script_vals) :: cache
),
1388 update_env newes
new_e
1389 (r.scr_rule_info
.rulename
:: rules_that_have_matched
))
1392 (if !Flag_cocci.show_dependencies
1394 let m2c (_,(r,x
),_) = r^
"."^x
in
1395 pr2
(Printf.sprintf
"script not applied: %s not bound"
1396 (String.concat
", " (List.map
m2c unbound
))));
1399 List.filter
(fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1400 (cache
, update_env newes
e rules_that_have_matched
))
1403 let rec apply_cocci_rule r rules_that_have_ever_matched es
1404 (ccs
:file_info list
ref) =
1405 Common.profile_code
r.rule_info
.rulename
(fun () ->
1406 show_or_not_rule_name r.ast_rule
r.rule_info
.ruleid
;
1407 show_or_not_ctl_text r.ctl
r.ast_rule
r.rule_info
.ruleid
;
1409 let reorganized_env =
1410 reassociate_positions
r.free_vars
r.negated_pos_vars
!es
in
1412 (* looping over the environments *)
1413 let (_,newes
(* envs for next round/rule *)) =
1415 (function (cache
,newes
) ->
1416 function ((e,rules_that_have_matched
),relevant_bindings) ->
1417 if not
(interpret_dependencies rules_that_have_matched
1418 !rules_that_have_ever_matched
1419 r.rule_info
.dependencies
)
1423 ("dependencies for rule "^
r.rule_info
.rulename^
1425 rules_that_have_matched
1426 !rules_that_have_ever_matched
r.rule_info
.dependencies
;
1427 show_or_not_binding "in environment" e;
1432 (fun (s,v
) -> List.mem
s r.rule_info
.used_after
))
1433 rules_that_have_matched
)
1437 try List.assoc
relevant_bindings cache
1441 ("dependencies for rule "^
r.rule_info
.rulename^
1443 rules_that_have_matched
1444 !rules_that_have_ever_matched
1445 r.rule_info
.dependencies
;
1446 show_or_not_binding "in" e;
1447 show_or_not_binding "relevant in" relevant_bindings;
1449 (* applying the rule *)
1450 (match r.ruletype
with
1452 (* looping over the functions and toplevel elements in
1455 (concat_headers_and_c !ccs
+>
1456 List.fold_left
(fun children_e
(c
,f) ->
1459 (* does also some side effects on c and r *)
1461 process_a_ctl_a_env_a_toplevel
r
1462 relevant_bindings c
f in
1463 match processed with
1464 | None
-> children_e
1465 | Some newbindings
->
1468 (fun children_e newbinding
->
1469 if List.mem newbinding children_e
1471 else newbinding
:: children_e
)
1475 | Ast_cocci.Generated
->
1476 process_a_generated_a_env_a_toplevel
r
1477 relevant_bindings !ccs
;
1480 let old_bindings_to_keep =
1484 (fun (s,v
) -> List.mem
s r.rule_info
.used_after
)) in
1486 if null
new_bindings
1489 (*use the old bindings, specialized to the used_after_list*)
1490 if !Flag_ctl.partial_match
1493 "Empty list of bindings, I will restart from old env\n";
1494 [(old_bindings_to_keep,rules_that_have_matched
)]
1497 (* combine the new bindings with the old ones, and
1498 specialize to the used_after_list *)
1499 let old_variables = List.map fst
old_bindings_to_keep in
1500 (* have to explicitly discard the inherited variables
1501 because we want the inherited value of the positions
1502 variables not the extended one created by
1503 reassociate_positions. want to reassociate freshly
1504 according to the free variables of each rule. *)
1505 let new_bindings_to_add =
1511 (* see comment before combine_pos *)
1512 (s,Ast_c.MetaPosValList
[]) -> false
1514 List.mem
s r.rule_info
.used_after
&&
1515 not
(List.mem
s old_variables)))) in
1517 (function new_binding_to_add
->
1520 old_bindings_to_keep new_binding_to_add
),
1521 r.rule_info
.rulename
::rules_that_have_matched
))
1522 new_bindings_to_add in
1523 ((relevant_bindings,new_bindings)::cache
,
1524 Common.profile_code
"merge_env" (function _ ->
1525 merge_env new_e newes
)))
1526 ([],init_env()) reorganized_env in (* end iter es *)
1527 if !(r.rule_info
.was_matched
)
1528 then Common.push2
r.rule_info
.rulename rules_that_have_ever_matched
;
1530 es
:= end_env newes
;
1532 (* apply the tagged modifs and reparse *)
1533 if not
!Flag.sgrep_mode2
1534 then ccs
:= rebuild_info_c_and_headers !ccs
r.isexp
)
1536 and reassociate_positions free_vars negated_pos_vars envs
=
1537 (* issues: isolate the bindings that are relevant to a given rule.
1538 separate out the position variables
1539 associate all of the position variables for a given set of relevant
1540 normal variable bindings with each set of relevant normal variable
1541 bindings. Goal: if eg if@p (E) matches in two places, then both inherited
1542 occurrences of E should see both bindings of p, not just its own.
1543 Otherwise, a position constraint for something that matches in two
1544 places will never be useful, because the position can always be
1545 different from the other one. *)
1549 List.filter
(function (x
,_) -> List.mem x free_vars
) e)
1551 let splitted_relevant =
1552 (* separate the relevant variables into the non-position ones and the
1557 (function (non_pos
,pos
) ->
1558 function (v
,_) as x
->
1559 if List.mem v negated_pos_vars
1560 then (non_pos
,x
::pos
)
1561 else (x
::non_pos
,pos
))
1564 let splitted_relevant =
1566 (function (non_pos
,pos
) ->
1567 (List.sort compare non_pos
,List.sort compare pos
))
1568 splitted_relevant in
1571 (function non_pos
->
1573 if List.mem np non_pos
then non_pos
else np
::non_pos
)
1574 [] splitted_relevant in
1575 let extended_relevant =
1576 (* extend the position variables with the values found at other identical
1577 variable bindings *)
1579 (function non_pos
->
1582 (function (other_non_pos
,other_pos
) ->
1583 (* do we want equal? or just somehow compatible? eg non_pos
1584 binds only E, but other_non_pos binds both E and E1 *)
1585 non_pos
=*= other_non_pos
)
1586 splitted_relevant in
1590 (combine_pos negated_pos_vars
1591 (List.map
(function (_,x
) -> x
) others)))))
1594 (List.map
(function (non_pos
,_) -> List.assoc non_pos
extended_relevant)
1597 (* If the negated posvar is not bound at all, this function will
1598 nevertheless bind it to []. If we get rid of these bindings, then the
1599 matching of the term the position variable with the constraints will fail
1600 because some variables are unbound. So we let the binding be [] and then
1601 we will have to clean these up afterwards. This should be the only way
1602 that a position variable can have an empty binding. *)
1603 and combine_pos negated_pos_vars
others =
1609 (function positions ->
1610 function other_list
->
1612 match List.assoc posvar other_list
with
1613 Ast_c.MetaPosValList l1
->
1614 Common.union_set l1
positions
1615 | _ -> failwith
"bad value for a position variable"
1616 with Not_found
-> positions)
1618 (posvar
,Ast_c.MetaPosValList
positions))
1621 and process_a_generated_a_env_a_toplevel2
r env = function
1626 (rule
,_) when rule
=$
= r.rule_info
.rulename
-> false
1627 | (_,"ARGS") -> false
1630 let env_domain = List.map
(function (nm
,vl
) -> nm
) env in
1634 let (rl
,_) = Ast_cocci.get_meta_name md
in rl
=$
= r.rule_info
.rulename
)
1636 if Common.include_set
free_vars env_domain
1637 then Unparse_hrule.pp_rule
metavars r.ast_rule
env cfile.full_fname
1638 | _ -> failwith
"multiple files not supported"
1640 and process_a_generated_a_env_a_toplevel rule
env ccs
=
1641 Common.profile_code
"process_a_ctl_a_env_a_toplevel"
1642 (fun () -> process_a_generated_a_env_a_toplevel2 rule
env ccs
)
1644 (* does side effects on C ast and on Cocci info rule *)
1645 and process_a_ctl_a_env_a_toplevel2
r e c
f =
1646 indent_do
(fun () ->
1647 show_or_not_celem "trying" c
.ast_c
;
1648 Flag.currentfile
:= Some
(f ^
":" ^
get_celem c
.ast_c
);
1649 match (r.ctl
,c
.ast_c
) with
1650 ((Asttoctl2.NONDECL ctl
,t
),Ast_c.Declaration
_) -> None
1651 | ((Asttoctl2.NONDECL ctl
,t
), _)
1652 | ((Asttoctl2.CODE ctl
,t
), _) ->
1653 let ctl = (ctl,t
) in (* ctl and other info *)
1654 let (trans_info, returned_any_states
, inherited_bindings
, newbindings
) =
1655 Common.save_excursion
Flag_ctl.loop_in_src_code
(fun () ->
1656 Flag_ctl.loop_in_src_code
:=
1657 !Flag_ctl.loop_in_src_code
||c
.contain_loop;
1659 (***************************************)
1660 (* !Main point! The call to the engine *)
1661 (***************************************)
1663 CCI.model_for_ctl
r.dropped_isos
(Common.some c
.flow) e
1664 in CCI.mysat
model_ctl ctl
1665 (r.rule_info
.rulename
, r.rule_info
.used_after
, e))
1667 if not returned_any_states
1671 show_or_not_celem "found match in" c
.ast_c
;
1672 show_or_not_trans_info trans_info;
1673 List.iter
(show_or_not_binding "out") newbindings
;
1675 r.rule_info
.was_matched
:= true;
1677 if not
(null
trans_info) &&
1678 not
(!Flag.sgrep_mode2
&& not
!Flag_cocci.show_diff
)
1681 c
.was_modified
:= true;
1683 (* les "more than one var in a decl" et "already tagged token"
1684 * font crasher coccinelle. Si on a 5 fichiers, donc on a 5
1685 * failed. Le try limite le scope des crashes pendant la
1686 * trasformation au fichier concerne. *)
1688 (* modify ast via side effect *)
1690 (Transformation_c.transform
r.rule_info
.rulename
1692 inherited_bindings
trans_info (Common.some c
.flow));
1693 with Timeout
-> raise Timeout
| UnixExit i
-> raise
(UnixExit i
)
1696 Some
(List.map
(function x
-> x
@inherited_bindings
) newbindings
)
1700 and process_a_ctl_a_env_a_toplevel a b c
f=
1701 Common.profile_code
"process_a_ctl_a_env_a_toplevel"
1702 (fun () -> process_a_ctl_a_env_a_toplevel2 a b c
f)
1705 let rec bigloop2 rs
(ccs
: file_info list
) =
1706 let init_es = [(Ast_c.emptyMetavarsBinding
,[])] in
1707 let es = ref init_es in
1708 let ccs = ref ccs in
1709 let rules_that_have_ever_matched = ref [] in
1713 (* looping over the rules *)
1714 rs
+> List.iter
(fun r ->
1716 InitialScriptRuleCocciInfo
r | FinalScriptRuleCocciInfo
r -> ()
1717 | ScriptRuleCocciInfo
r ->
1718 if !Flag_cocci.show_ctl_text
then begin
1719 Common.pr_xxxxxxxxxxxxxxxxx
();
1720 pr
("script: " ^
r.language
);
1721 Common.pr_xxxxxxxxxxxxxxxxx
();
1723 adjust_pp_with_indent
(fun () ->
1724 Format.force_newline
();
1725 let (l,mv,script_vars
,code
) = r.scr_ast_rule
in
1726 let nm = r.scr_rule_info
.rulename
in
1727 let deps = r.scr_rule_info
.dependencies
in
1728 Pretty_print_cocci.unparse
1729 (Ast_cocci.ScriptRule
(nm,l,deps,mv,script_vars
,code
)));
1732 (*pr2 (List.hd(cmd_to_list "free -m | grep Mem"));*)
1733 if !Flag.show_misc
then print_endline
"RESULT =";
1737 (function (cache
, newes
) ->
1738 function (e, rules_that_have_matched
) ->
1739 match r.language
with
1741 apply_script_rule r cache newes
e rules_that_have_matched
1742 rules_that_have_ever_matched python_application
1744 apply_script_rule r cache newes
e rules_that_have_matched
1745 rules_that_have_ever_matched ocaml_application
1747 concat_headers_and_c !ccs +> List.iter
(fun (c
,_) ->
1750 Printf.printf
"Flow: %s\r\nFlow!\r\n%!" c
.fullstring
);
1753 Printf.printf
"Unknown language: %s\n" r.language
;
1755 ([],init_env()) !es in
1757 (if !(r.scr_rule_info
.was_matched
)
1759 Common.push2
r.scr_rule_info
.rulename
rules_that_have_ever_matched);
1761 (* just newes can't work, because if one does include_match false
1762 on everything that binds a variable, then nothing is left *)
1764 (if Hashtbl.length newes
= 0 then init_es else end_env newes
)
1765 | CocciRuleCocciInfo
r ->
1766 apply_cocci_rule r rules_that_have_ever_matched
1770 if !Flag.sgrep_mode2
1772 (* sgrep can lead to code that is not parsable, but we must
1773 * still call rebuild_info_c_and_headers to pretty print the
1774 * action (MINUS), so that later the diff will show what was
1775 * matched by sgrep. But we don't want the parsing error message
1776 * hence the following flag setting. So this code propably
1777 * will generate a NotParsedCorrectly for the matched parts
1778 * and the very final pretty print and diff will work
1780 Flag_parsing_c.verbose_parsing
:= false;
1781 ccs := rebuild_info_c_and_headers !ccs false
1783 !ccs (* return final C asts *)
1786 Common.profile_code
"bigloop" (fun () -> bigloop2 a b
)
1788 type init_final
= Initial
| Final
1790 let initial_final_bigloop2 ty rebuild
r =
1791 if !Flag_cocci.show_ctl_text
then
1793 Common.pr_xxxxxxxxxxxxxxxxx
();
1794 pr
((match ty
with Initial
-> "initial" | Final
-> "final") ^
": " ^
1796 Common.pr_xxxxxxxxxxxxxxxxx
();
1798 adjust_pp_with_indent
(fun () ->
1799 Format.force_newline
();
1800 Pretty_print_cocci.unparse
(rebuild
r.scr_ast_rule
r.scr_rule_info
.dependencies
));
1803 match r.language
with
1805 (* include_match makes no sense in an initial or final rule, although
1806 we have no way to prevent it *)
1807 let newes = init_env() in
1808 let _ = apply_script_rule r [] newes [] [] (ref []) python_application in
1810 | "ocaml" when ty
= Initial
-> () (* nothing to do *)
1812 (* include_match makes no sense in an initial or final rule, although
1813 we have no way to prevent it *)
1814 let newes = init_env() in
1815 let _ = apply_script_rule r [] newes [] [] (ref []) ocaml_application in
1818 failwith
("Unknown language for initial/final script: "^
1821 let initial_final_bigloop a b c
=
1822 Common.profile_code
"initial_final_bigloop"
1823 (fun () -> initial_final_bigloop2 a b c
)
1825 (*****************************************************************************)
1826 (* The main functions *)
1827 (*****************************************************************************)
1829 let pre_engine2 (coccifile
, isofile
) =
1830 show_or_not_cocci coccifile isofile
;
1831 Pycocci.set_coccifile coccifile
;
1834 if not
(Common.lfile_exists
isofile)
1836 pr2
("warning: Can't find default iso file: " ^
isofile);
1839 else Some
isofile in
1841 (* useful opti when use -dir *)
1842 let (metavars,astcocci
,
1843 free_var_lists
,negated_pos_lists
,used_after_lists
,
1844 positions_lists
,(toks
,_,_)) = sp_of_file coccifile
isofile in
1846 let ctls = ctls_of_ast astcocci used_after_lists positions_lists
in
1848 g_contain_typedmetavar := sp_contain_typed_metavar astcocci
;
1850 check_macro_in_sp_and_adjust toks
;
1852 show_or_not_ctl_tex astcocci
ctls;
1855 prepare_cocci ctls free_var_lists negated_pos_lists
1856 used_after_lists positions_lists
metavars astcocci
in
1858 let used_languages =
1860 (function languages
->
1862 ScriptRuleCocciInfo
(r) ->
1863 if List.mem
r.language languages
then
1866 r.language
::languages
1871 let rlang = r.language
in
1872 let rname = r.scr_rule_info
.rulename
in
1874 let _ = List.assoc
(rlang,rname) !Iteration.initialization_stack
in
1878 Iteration.initialization_stack
:=
1879 ((rlang,rname),!Flag.defined_virtual_rules
) ::
1880 !Iteration.initialization_stack
;
1881 initial_final_bigloop Initial
1882 (fun (x
,_,_,y
) -> fun deps ->
1883 Ast_cocci.InitialScriptRule
(rname,x
,deps,y
))
1887 let initialized_languages =
1889 (function languages
->
1891 InitialScriptRuleCocciInfo
(r) ->
1892 let rlang = r.language
in
1893 (if List.mem
rlang languages
1894 then failwith
("double initializer found for "^
rlang));
1895 if interpret_dependencies [] [] r.scr_rule_info
.dependencies
1896 then begin runrule r; rlang::languages
end
1901 let uninitialized_languages =
1903 (fun used
-> not
(List.mem used
initialized_languages))
1910 dependencies
= Ast_cocci.NoDep
;
1913 was_matched
= ref false;} in
1914 runrule (make_init lgg
"" rule_info))
1915 uninitialized_languages;
1920 Common.profile_code
"pre_engine" (fun () -> pre_engine2 a
)
1922 let full_engine2 (cocci_infos,toks
) cfiles =
1924 show_or_not_cfiles cfiles;
1926 (* optimisation allowing to launch coccinelle on all the drivers *)
1927 if !Flag_cocci.worth_trying_opt
&& not
(worth_trying cfiles toks
)
1933 pr2
("No matches found for " ^
(Common.join
" " toks
)
1934 ^
"\nSkipping:" ^
(Common.join
" " cfiles)));
1935 cfiles +> List.map
(fun s -> s, None
)
1940 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1941 if !Flag.show_misc
then pr
"let's go";
1942 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1944 if !Flag_cocci.show_binding_in_out
1947 (match !Flag.defined_virtual_rules
with
1949 | l -> pr
(Printf.sprintf
"Defined virtual rules: %s"
1950 (String.concat
" " l)));
1953 pr
(Printf.sprintf
"%s = %s" v vl
))
1954 !Flag.defined_virtual_env
;
1955 Common.pr_xxxxxxxxxxxxxxxxx
()
1958 let choose_includes =
1959 match !Flag_cocci.include_options
with
1960 Flag_cocci.I_UNSPECIFIED
->
1961 if !g_contain_typedmetavar
1962 then Flag_cocci.I_NORMAL_INCLUDES
1963 else Flag_cocci.I_NO_INCLUDES
1965 let c_infos = prepare_c cfiles choose_includes in
1967 (* ! the big loop ! *)
1968 let c_infos'
= bigloop cocci_infos c_infos in
1970 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1971 if !Flag.show_misc
then pr
"Finished";
1972 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1973 if !Flag_ctl.graphical_trace
then gen_pdf_graph ();
1975 c_infos'
+> List.map
(fun c_or_h
->
1976 if !(c_or_h
.was_modified_once
)
1980 Common.new_temp_file
"cocci-output" ("-" ^ c_or_h
.fname
) in
1982 if c_or_h
.fkind
=*= Header
1983 then pr2
("a header file was modified: " ^ c_or_h
.fname
);
1985 (* and now unparse everything *)
1986 cfile_of_program (for_unparser c_or_h
.asts
) outfile;
1988 show_or_not_diff c_or_h
.fpath
outfile;
1991 if !Flag.sgrep_mode2
then None
else Some
outfile)
1993 else (c_or_h
.fpath
, None
))
1996 let full_engine a b
=
1997 Common.profile_code
"full_engine"
1998 (fun () -> let res = full_engine2 a b
in (*Gc.print_stat stderr; *)res)
2000 let post_engine2 (cocci_infos,_) =
2002 (function ((language
,_),virt_rules
) ->
2003 Flag.defined_virtual_rules
:= virt_rules
;
2006 (function languages
->
2008 FinalScriptRuleCocciInfo
(r) ->
2009 (if r.language
= language
&& List.mem
r.language languages
2010 then failwith
("double finalizer found for "^
r.language
));
2011 initial_final_bigloop Final
2012 (fun (x
,_,_,y
) -> fun deps ->
2013 Ast_cocci.FinalScriptRule
(r.scr_rule_info
.rulename
,
2016 r.language
::languages
2020 !Iteration.initialization_stack
2023 Common.profile_code
"post_engine" (fun () -> post_engine2 a
)
2025 (*****************************************************************************)
2026 (* check duplicate from result of full_engine *)
2027 (*****************************************************************************)
2029 let check_duplicate_modif2 xs =
2030 (* opti: let groups = Common.groupBy (fun (a,resa) (b,resb) -> a =$= b) xs *)
2031 if !Flag_cocci.verbose_cocci
2032 then pr2
("Check duplication for " ^ i_to_s
(List.length
xs) ^
" files");
2034 let groups = Common.group_assoc_bykey_eff
xs in
2035 groups +> Common.map_filter
(fun (file, xs) ->
2037 | [] -> raise
(Impossible
162)
2038 | [res] -> Some
(file, res)
2042 if not
(List.for_all
(fun res2
-> res2
=*= None
) xs)
2044 pr2
("different modification result for " ^
file);
2047 else Some
(file, None
)
2049 if not
(List.for_all
(fun res2
->
2053 let diff = Common.cmd_to_list
("diff -u -b -B "^
res^
" "^res2
)
2057 pr2
("different modification result for " ^
file);
2060 else Some
(file, Some
res)
2062 let check_duplicate_modif a
=
2063 Common.profile_code
"check_duplicate" (fun () -> check_duplicate_modif2 a
)