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;
1081 ast_c
= c
; (* contain refs so can be modified *)
1083 fullstring
= fullstr
;
1087 contain_loop = contain_loop flow;
1089 env_typing_before
= enva
;
1090 env_typing_after
= envb
;
1092 was_modified
= ref false;
1094 all_typedefs
= typedefs
;
1095 all_macros
= macros
;
1101 (* Optimisation. Try not unparse/reparse the whole file when have modifs *)
1102 let rebuild_info_program cs file isexp
=
1103 cs +> List.map
(fun c
->
1104 if !(c
.was_modified
)
1106 let file = Common.new_temp_file
"cocci_small_output" ".c" in
1108 [(c
.ast_c
, (c
.fullstring
, c
.tokens_c
)), Unparse_c.PPnormal
]
1111 (* Common.command2 ("cat " ^ file); *)
1112 let cprogram = cprogram_of_file c
.all_typedefs c
.all_macros
file in
1113 let xs = build_info_program cprogram c
.env_typing_before
in
1115 (* TODO: assert env has not changed,
1116 * if yes then must also reparse what follows even if not modified.
1117 * Do that only if contain_typedmetavar of course, so good opti.
1119 (* Common.list_init xs *) (* get rid of the FinalDef *)
1125 let rebuild_info_c_and_headers ccs isexp
=
1126 ccs
+> List.iter
(fun c_or_h
->
1127 if c_or_h
.asts
+> List.exists
(fun c
-> !(c
.was_modified
))
1128 then c_or_h
.was_modified_once
:= true;
1130 ccs
+> List.map
(fun c_or_h
->
1133 rebuild_info_program c_or_h
.asts c_or_h
.full_fname isexp
}
1136 let rec prepare_h seen env hpath choose_includes
: file_info list
=
1137 if not
(Common.lfile_exists hpath
)
1140 pr2_once
("TYPE: header " ^ hpath ^
" not found");
1145 let h_cs = cprogram_of_file_cached hpath
in
1146 let local_includes =
1147 if choose_includes
=*= Flag_cocci.I_REALLY_ALL_INCLUDES
1150 (function x
-> not
(List.mem x
!seen))
1151 (includes_to_parse
[(hpath
,h_cs)] choose_includes
)
1153 seen := local_includes @ !seen;
1156 (List.map
(function x
-> prepare_h seen env x choose_includes
)
1158 let info_h_cs = build_info_program h_cs !env
in
1162 else last_env_toplevel_c_info info_h_cs;
1165 fname
= Common.basename hpath
;
1168 was_modified_once
= ref false;
1174 let prepare_c files choose_includes
: file_info list
=
1175 let cprograms = List.map
cprogram_of_file_cached files
in
1176 let includes = includes_to_parse
(zip files
cprograms) choose_includes
in
1177 let seen = ref includes in
1179 (* todo?: may not be good to first have all the headers and then all the c *)
1180 let env = ref !TAC.initial_env
in
1184 List.map
(function hpath
-> prepare_h seen env hpath choose_includes
) +>
1188 (zip files
cprograms) +>
1190 (function (file, cprogram) ->
1191 (* todo?: don't update env ? *)
1192 let cs = build_info_program cprogram !env in
1193 (* we do that only for the c, not for the h *)
1194 ignore
(update_include_rel_pos (cs +> List.map
(fun x
-> x
.ast_c
)));
1196 fname
= Common.basename
file;
1199 was_modified_once
= ref false;
1206 (*****************************************************************************)
1207 (* Manage environments as they are being built up *)
1208 (*****************************************************************************)
1210 let init_env _ = Hashtbl.create
101
1212 let update_env env v i
= Hashtbl.replace
env v i
; env
1214 (* know that there are no conflicts *)
1215 let safe_update_env env v i
= Hashtbl.add
env v i
; env
1218 List.sort compare
(Hashtbl.fold
(fun k v rest
-> (k
,v
) :: rest
) env [])
1220 (*****************************************************************************)
1221 (* Processing the ctls and toplevel C elements *)
1222 (*****************************************************************************)
1224 (* The main algorithm =~
1225 * The algorithm is roughly:
1226 * for_all ctl rules in SP
1227 * for_all minirule in rule (no more)
1228 * for_all binding (computed during previous phase)
1229 * for_all C elements
1230 * match control flow of function vs minirule
1231 * with the binding and update the set of possible
1232 * bindings, and returned the possibly modified function.
1233 * pretty print modified C elements and reparse it.
1236 * On ne prends que les newbinding ou returned_any_state est vrai.
1237 * Si ca ne donne rien, on prends ce qu'il y avait au depart.
1238 * Mais au nouveau depart de quoi ?
1239 * - si ca donne rien apres avoir traité toutes les fonctions avec ce binding ?
1240 * - ou alors si ca donne rien, apres avoir traité toutes les fonctions
1241 * avec tous les bindings du round d'avant ?
1243 * Julia pense qu'il faut prendre la premiere solution.
1244 * Example: on a deux environnements candidats, E1 et E2 apres avoir traité
1245 * la regle ctl 1. On arrive sur la regle ctl 2.
1246 * E1 ne donne rien pour la regle 2, on garde quand meme E1 pour la regle 3.
1247 * E2 donne un match a un endroit et rend E2' alors on utilise ca pour
1250 * I have not to look at used_after_list to decide to restart from
1251 * scratch. I just need to look if the binding list is empty.
1252 * Indeed, let's suppose that a SP have 3 regions/rules. If we
1253 * don't find a match for the first region, then if this first
1254 * region does not bind metavariable used after, that is if
1255 * used_after_list is empty, then mysat(), even if does not find a
1256 * match, will return a Left, with an empty transformation_info,
1257 * and so current_binding will grow. On the contrary if the first
1258 * region must bind some metavariables used after, and that we
1259 * dont find any such region, then mysat() will returns lots of
1260 * Right, and current_binding will not grow, and so we will have
1261 * an empty list of binding, and we will catch such a case.
1263 * opti: julia says that because the binding is
1264 * determined by the used_after_list, the items in the list
1265 * are kind of sorted, so could optimise the insert_set operations.
1269 (* r(ule), c(element in C code), e(nvironment) *)
1271 let merge_env new_e old_e
=
1273 (function (e
,rules
) ->
1274 let _ = update_env old_e e rules
in ()) new_e
;
1277 let contains_binding e
(_,(r,m
),_) =
1279 let _ = List.find
(function ((re
, rm
), _) -> r =*= re
&& m
=$
= rm
) e
in
1281 with Not_found
-> false
1285 let python_application mv ve script_vars
r =
1289 ((Some x
,None
),y
,z
) -> (x
,y
,z
)
1292 (Printf.sprintf
"unexpected ast metavar in rule %s"
1293 r.scr_rule_info
.rulename
))
1296 Pycocci.build_classes
(List.map
(function (x
,y
) -> x
) ve
);
1297 Pycocci.construct_variables
mv ve
;
1298 Pycocci.construct_script_variables script_vars
;
1299 let _ = Pycocci.pyrun_simplestring
(local_python_code ^
r.script_code
) in
1302 else if !Pycocci.inc_match
1303 then Some
(Pycocci.retrieve_script_variables script_vars
)
1305 with Pycocci.Pycocciexception
->
1306 (pr2
("Failure in " ^
r.scr_rule_info
.rulename
);
1307 raise
Pycocci.Pycocciexception
)
1309 let ocaml_application mv ve script_vars
r =
1312 Run_ocamlcocci.run
mv ve script_vars
1313 r.scr_rule_info
.rulename
r.script_code
in
1316 else if !Coccilib.inc_match
1317 then Some
script_vals
1319 with e
-> (pr2
("Failure in " ^
r.scr_rule_info
.rulename
); raise e
)
1321 (* returns Left in case of dependency failure, Right otherwise *)
1322 let apply_script_rule r cache newes e rules_that_have_matched
1323 rules_that_have_ever_matched script_application
=
1324 Common.profile_code
r.language
(fun () ->
1325 show_or_not_scr_rule_name r.scr_rule_info
.ruleid
;
1326 if not
(interpret_dependencies rules_that_have_matched
1327 !rules_that_have_ever_matched
r.scr_rule_info
.dependencies
)
1330 print_dependencies "dependencies for script not satisfied:"
1331 rules_that_have_matched
1332 !rules_that_have_ever_matched
r.scr_rule_info
.dependencies
;
1333 show_or_not_binding "in environment" e
;
1334 (cache
, safe_update_env newes e rules_that_have_matched
)
1338 let (_, mv, script_vars
, _) = r.scr_ast_rule
in
1340 (List.map
(function (n
,v
) -> (("virtual",n
),Ast_c.MetaIdVal
(v
,[])))
1341 !Flag.defined_virtual_env
) @ e
in
1342 let not_bound x
= not
(contains_binding ve x
) in
1343 (match List.filter
not_bound mv with
1345 let relevant_bindings =
1347 (function ((re
,rm
),_) ->
1348 List.exists
(function (_,(r,m
),_) -> r =*= re
&& m
=$
= rm
) mv)
1351 match List.assoc
relevant_bindings cache
with
1352 None
-> (cache
,newes
)
1353 | Some
script_vals ->
1355 "dependencies for script satisfied, but cached:"
1356 rules_that_have_matched
1357 !rules_that_have_ever_matched
1358 r.scr_rule_info
.dependencies
;
1359 show_or_not_binding "in" e
;
1360 (* env might be bigger than what was cached against, so have to
1361 merge with newes anyway *)
1362 let new_e = (List.combine script_vars
script_vals) @ e
in
1366 (fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1367 (cache
,update_env newes
new_e rules_that_have_matched
)
1370 print_dependencies "dependencies for script satisfied:"
1371 rules_that_have_matched
1372 !rules_that_have_ever_matched
1373 r.scr_rule_info
.dependencies
;
1374 show_or_not_binding "in" e
;
1375 match script_application
mv ve script_vars
r with
1377 (* failure means we should drop e, no new bindings *)
1378 (((relevant_bindings,None
) :: cache
), newes
)
1379 | Some
script_vals ->
1381 List.map
(function x
-> Ast_c.MetaIdVal
(x
,[]))
1383 let new_e = (List.combine script_vars
script_vals) @ e
in
1387 (fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1388 r.scr_rule_info
.was_matched
:= true;
1389 (((relevant_bindings,Some
script_vals) :: cache
),
1390 update_env newes
new_e
1391 (r.scr_rule_info
.rulename
:: rules_that_have_matched
))
1394 (if !Flag_cocci.show_dependencies
1396 let m2c (_,(r,x
),_) = r^
"."^x
in
1397 pr2
(Printf.sprintf
"script not applied: %s not bound"
1398 (String.concat
", " (List.map
m2c unbound
))));
1401 List.filter
(fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1402 (cache
, update_env newes
e rules_that_have_matched
))
1405 let rec apply_cocci_rule r rules_that_have_ever_matched es
1406 (ccs
:file_info list
ref) =
1407 Common.profile_code
r.rule_info
.rulename
(fun () ->
1408 show_or_not_rule_name r.ast_rule
r.rule_info
.ruleid
;
1409 show_or_not_ctl_text r.ctl
r.ast_rule
r.rule_info
.ruleid
;
1411 let reorganized_env =
1412 reassociate_positions
r.free_vars
r.negated_pos_vars
!es
in
1414 (* looping over the environments *)
1415 let (_,newes
(* envs for next round/rule *)) =
1417 (function (cache
,newes
) ->
1418 function ((e,rules_that_have_matched
),relevant_bindings) ->
1419 if not
(interpret_dependencies rules_that_have_matched
1420 !rules_that_have_ever_matched
1421 r.rule_info
.dependencies
)
1425 ("dependencies for rule "^
r.rule_info
.rulename^
1427 rules_that_have_matched
1428 !rules_that_have_ever_matched
r.rule_info
.dependencies
;
1429 show_or_not_binding "in environment" e;
1434 (fun (s,v
) -> List.mem
s r.rule_info
.used_after
))
1435 rules_that_have_matched
)
1439 try List.assoc
relevant_bindings cache
1443 ("dependencies for rule "^
r.rule_info
.rulename^
1445 rules_that_have_matched
1446 !rules_that_have_ever_matched
1447 r.rule_info
.dependencies
;
1448 show_or_not_binding "in" e;
1449 show_or_not_binding "relevant in" relevant_bindings;
1451 (* applying the rule *)
1452 (match r.ruletype
with
1454 (* looping over the functions and toplevel elements in
1457 (concat_headers_and_c !ccs
+>
1458 List.fold_left
(fun children_e
(c
,f) ->
1461 (* does also some side effects on c and r *)
1463 process_a_ctl_a_env_a_toplevel
r
1464 relevant_bindings c
f in
1465 match processed with
1466 | None
-> children_e
1467 | Some newbindings
->
1470 (fun children_e newbinding
->
1471 if List.mem newbinding children_e
1473 else newbinding
:: children_e
)
1477 | Ast_cocci.Generated
->
1478 process_a_generated_a_env_a_toplevel
r
1479 relevant_bindings !ccs
;
1482 let old_bindings_to_keep =
1486 (fun (s,v
) -> List.mem
s r.rule_info
.used_after
)) in
1488 if null
new_bindings
1491 (*use the old bindings, specialized to the used_after_list*)
1492 if !Flag_ctl.partial_match
1495 "Empty list of bindings, I will restart from old env\n";
1496 [(old_bindings_to_keep,rules_that_have_matched
)]
1499 (* combine the new bindings with the old ones, and
1500 specialize to the used_after_list *)
1501 let old_variables = List.map fst
old_bindings_to_keep in
1502 (* have to explicitly discard the inherited variables
1503 because we want the inherited value of the positions
1504 variables not the extended one created by
1505 reassociate_positions. want to reassociate freshly
1506 according to the free variables of each rule. *)
1507 let new_bindings_to_add =
1513 (* see comment before combine_pos *)
1514 (s,Ast_c.MetaPosValList
[]) -> false
1516 List.mem
s r.rule_info
.used_after
&&
1517 not
(List.mem
s old_variables)))) in
1519 (function new_binding_to_add
->
1522 old_bindings_to_keep new_binding_to_add
),
1523 r.rule_info
.rulename
::rules_that_have_matched
))
1524 new_bindings_to_add in
1525 ((relevant_bindings,new_bindings)::cache
,
1526 Common.profile_code
"merge_env" (function _ ->
1527 merge_env new_e newes
)))
1528 ([],init_env()) reorganized_env in (* end iter es *)
1529 if !(r.rule_info
.was_matched
)
1530 then Common.push2
r.rule_info
.rulename rules_that_have_ever_matched
;
1532 es
:= end_env newes
;
1534 (* apply the tagged modifs and reparse *)
1535 if not
!Flag.sgrep_mode2
1536 then ccs
:= rebuild_info_c_and_headers !ccs
r.isexp
)
1538 and reassociate_positions free_vars negated_pos_vars envs
=
1539 (* issues: isolate the bindings that are relevant to a given rule.
1540 separate out the position variables
1541 associate all of the position variables for a given set of relevant
1542 normal variable bindings with each set of relevant normal variable
1543 bindings. Goal: if eg if@p (E) matches in two places, then both inherited
1544 occurrences of E should see both bindings of p, not just its own.
1545 Otherwise, a position constraint for something that matches in two
1546 places will never be useful, because the position can always be
1547 different from the other one. *)
1551 List.filter
(function (x
,_) -> List.mem x free_vars
) e)
1553 let splitted_relevant =
1554 (* separate the relevant variables into the non-position ones and the
1559 (function (non_pos
,pos
) ->
1560 function (v
,_) as x
->
1561 if List.mem v negated_pos_vars
1562 then (non_pos
,x
::pos
)
1563 else (x
::non_pos
,pos
))
1566 let splitted_relevant =
1568 (function (non_pos
,pos
) ->
1569 (List.sort compare non_pos
,List.sort compare pos
))
1570 splitted_relevant in
1573 (function non_pos
->
1575 if List.mem np non_pos
then non_pos
else np
::non_pos
)
1576 [] splitted_relevant in
1577 let extended_relevant =
1578 (* extend the position variables with the values found at other identical
1579 variable bindings *)
1581 (function non_pos
->
1584 (function (other_non_pos
,other_pos
) ->
1585 (* do we want equal? or just somehow compatible? eg non_pos
1586 binds only E, but other_non_pos binds both E and E1 *)
1587 non_pos
=*= other_non_pos
)
1588 splitted_relevant in
1592 (combine_pos negated_pos_vars
1593 (List.map
(function (_,x
) -> x
) others)))))
1596 (List.map
(function (non_pos
,_) -> List.assoc non_pos
extended_relevant)
1599 (* If the negated posvar is not bound at all, this function will
1600 nevertheless bind it to []. If we get rid of these bindings, then the
1601 matching of the term the position variable with the constraints will fail
1602 because some variables are unbound. So we let the binding be [] and then
1603 we will have to clean these up afterwards. This should be the only way
1604 that a position variable can have an empty binding. *)
1605 and combine_pos negated_pos_vars
others =
1611 (function positions ->
1612 function other_list
->
1614 match List.assoc posvar other_list
with
1615 Ast_c.MetaPosValList l1
->
1616 Common.union_set l1
positions
1617 | _ -> failwith
"bad value for a position variable"
1618 with Not_found
-> positions)
1620 (posvar
,Ast_c.MetaPosValList
positions))
1623 and process_a_generated_a_env_a_toplevel2
r env = function
1628 (rule
,_) when rule
=$
= r.rule_info
.rulename
-> false
1629 | (_,"ARGS") -> false
1632 let env_domain = List.map
(function (nm
,vl
) -> nm
) env in
1636 let (rl
,_) = Ast_cocci.get_meta_name md
in rl
=$
= r.rule_info
.rulename
)
1638 if Common.include_set
free_vars env_domain
1639 then Unparse_hrule.pp_rule
metavars r.ast_rule
env cfile.full_fname
1640 | _ -> failwith
"multiple files not supported"
1642 and process_a_generated_a_env_a_toplevel rule
env ccs
=
1643 Common.profile_code
"process_a_ctl_a_env_a_toplevel"
1644 (fun () -> process_a_generated_a_env_a_toplevel2 rule
env ccs
)
1646 (* does side effects on C ast and on Cocci info rule *)
1647 and process_a_ctl_a_env_a_toplevel2
r e c
f =
1648 indent_do
(fun () ->
1649 show_or_not_celem "trying" c
.ast_c
;
1650 Flag.currentfile
:= Some
(f ^
":" ^
get_celem c
.ast_c
);
1651 match (r.ctl
,c
.ast_c
) with
1652 ((Asttoctl2.NONDECL ctl
,t
),Ast_c.Declaration
_) -> None
1653 | ((Asttoctl2.NONDECL ctl
,t
), _)
1654 | ((Asttoctl2.CODE ctl
,t
), _) ->
1655 let ctl = (ctl,t
) in (* ctl and other info *)
1656 let (trans_info, returned_any_states
, inherited_bindings
, newbindings
) =
1657 Common.save_excursion
Flag_ctl.loop_in_src_code
(fun () ->
1658 Flag_ctl.loop_in_src_code
:=
1659 !Flag_ctl.loop_in_src_code
||c
.contain_loop;
1661 (***************************************)
1662 (* !Main point! The call to the engine *)
1663 (***************************************)
1665 CCI.model_for_ctl
r.dropped_isos
(Common.some c
.flow) e
1666 in CCI.mysat
model_ctl ctl
1667 (r.rule_info
.rulename
, r.rule_info
.used_after
, e))
1669 if not returned_any_states
1673 show_or_not_celem "found match in" c
.ast_c
;
1674 show_or_not_trans_info trans_info;
1675 List.iter
(show_or_not_binding "out") newbindings
;
1677 r.rule_info
.was_matched
:= true;
1679 if not
(null
trans_info) &&
1680 not
(!Flag.sgrep_mode2
&& not
!Flag_cocci.show_diff
)
1683 c
.was_modified
:= true;
1685 (* les "more than one var in a decl" et "already tagged token"
1686 * font crasher coccinelle. Si on a 5 fichiers, donc on a 5
1687 * failed. Le try limite le scope des crashes pendant la
1688 * trasformation au fichier concerne. *)
1690 (* modify ast via side effect *)
1692 (Transformation_c.transform
r.rule_info
.rulename
1694 inherited_bindings
trans_info (Common.some c
.flow));
1695 with Timeout
-> raise Timeout
| UnixExit i
-> raise
(UnixExit i
)
1698 Some
(List.map
(function x
-> x
@inherited_bindings
) newbindings
)
1702 and process_a_ctl_a_env_a_toplevel a b c
f=
1703 Common.profile_code
"process_a_ctl_a_env_a_toplevel"
1704 (fun () -> process_a_ctl_a_env_a_toplevel2 a b c
f)
1707 let rec bigloop2 rs
(ccs
: file_info list
) =
1708 let init_es = [(Ast_c.emptyMetavarsBinding
,[])] in
1709 let es = ref init_es in
1710 let ccs = ref ccs in
1711 let rules_that_have_ever_matched = ref [] in
1715 (* looping over the rules *)
1716 rs
+> List.iter
(fun r ->
1718 InitialScriptRuleCocciInfo
r | FinalScriptRuleCocciInfo
r -> ()
1719 | ScriptRuleCocciInfo
r ->
1720 if !Flag_cocci.show_ctl_text
then begin
1721 Common.pr_xxxxxxxxxxxxxxxxx
();
1722 pr
("script: " ^
r.language
);
1723 Common.pr_xxxxxxxxxxxxxxxxx
();
1725 adjust_pp_with_indent
(fun () ->
1726 Format.force_newline
();
1727 let (l,mv,script_vars
,code
) = r.scr_ast_rule
in
1728 let nm = r.scr_rule_info
.rulename
in
1729 let deps = r.scr_rule_info
.dependencies
in
1730 Pretty_print_cocci.unparse
1731 (Ast_cocci.ScriptRule
(nm,l,deps,mv,script_vars
,code
)));
1734 (*pr2 (List.hd(cmd_to_list "free -m | grep Mem"));*)
1735 if !Flag.show_misc
then print_endline
"RESULT =";
1739 (function (cache
, newes
) ->
1740 function (e, rules_that_have_matched
) ->
1741 match r.language
with
1743 apply_script_rule r cache newes
e rules_that_have_matched
1744 rules_that_have_ever_matched python_application
1746 apply_script_rule r cache newes
e rules_that_have_matched
1747 rules_that_have_ever_matched ocaml_application
1749 concat_headers_and_c !ccs +> List.iter
(fun (c
,_) ->
1752 Printf.printf
"Flow: %s\r\nFlow!\r\n%!" c
.fullstring
);
1755 Printf.printf
"Unknown language: %s\n" r.language
;
1757 ([],init_env()) !es in
1759 (if !(r.scr_rule_info
.was_matched
)
1761 Common.push2
r.scr_rule_info
.rulename
rules_that_have_ever_matched);
1763 (* just newes can't work, because if one does include_match false
1764 on everything that binds a variable, then nothing is left *)
1766 (if Hashtbl.length newes
= 0 then init_es else end_env newes
)
1767 | CocciRuleCocciInfo
r ->
1768 apply_cocci_rule r rules_that_have_ever_matched
1772 if !Flag.sgrep_mode2
1774 (* sgrep can lead to code that is not parsable, but we must
1775 * still call rebuild_info_c_and_headers to pretty print the
1776 * action (MINUS), so that later the diff will show what was
1777 * matched by sgrep. But we don't want the parsing error message
1778 * hence the following flag setting. So this code propably
1779 * will generate a NotParsedCorrectly for the matched parts
1780 * and the very final pretty print and diff will work
1782 Flag_parsing_c.verbose_parsing
:= false;
1783 ccs := rebuild_info_c_and_headers !ccs false
1785 !ccs (* return final C asts *)
1788 Common.profile_code
"bigloop" (fun () -> bigloop2 a b
)
1790 type init_final
= Initial
| Final
1792 let initial_final_bigloop2 ty rebuild
r =
1793 if !Flag_cocci.show_ctl_text
then
1795 Common.pr_xxxxxxxxxxxxxxxxx
();
1796 pr
((match ty
with Initial
-> "initial" | Final
-> "final") ^
": " ^
1798 Common.pr_xxxxxxxxxxxxxxxxx
();
1800 adjust_pp_with_indent
(fun () ->
1801 Format.force_newline
();
1802 Pretty_print_cocci.unparse
(rebuild
r.scr_ast_rule
r.scr_rule_info
.dependencies
));
1805 match r.language
with
1807 (* include_match makes no sense in an initial or final rule, although
1808 we have no way to prevent it *)
1809 let newes = init_env() in
1810 let _ = apply_script_rule r [] newes [] [] (ref []) python_application in
1812 | "ocaml" when ty
= Initial
-> () (* nothing to do *)
1814 (* include_match makes no sense in an initial or final rule, although
1815 we have no way to prevent it *)
1816 let newes = init_env() in
1817 let _ = apply_script_rule r [] newes [] [] (ref []) ocaml_application in
1820 failwith
("Unknown language for initial/final script: "^
1823 let initial_final_bigloop a b c
=
1824 Common.profile_code
"initial_final_bigloop"
1825 (fun () -> initial_final_bigloop2 a b c
)
1827 (*****************************************************************************)
1828 (* The main functions *)
1829 (*****************************************************************************)
1831 let pre_engine2 (coccifile
, isofile
) =
1832 show_or_not_cocci coccifile isofile
;
1833 Pycocci.set_coccifile coccifile
;
1836 if not
(Common.lfile_exists
isofile)
1838 pr2
("warning: Can't find default iso file: " ^
isofile);
1841 else Some
isofile in
1843 (* useful opti when use -dir *)
1844 let (metavars,astcocci
,
1845 free_var_lists
,negated_pos_lists
,used_after_lists
,
1846 positions_lists
,(toks
,_,_)) = sp_of_file coccifile
isofile in
1848 let ctls = ctls_of_ast astcocci used_after_lists positions_lists
in
1850 g_contain_typedmetavar := sp_contain_typed_metavar astcocci
;
1852 check_macro_in_sp_and_adjust toks
;
1854 show_or_not_ctl_tex astcocci
ctls;
1857 prepare_cocci ctls free_var_lists negated_pos_lists
1858 used_after_lists positions_lists
metavars astcocci
in
1860 let used_languages =
1862 (function languages
->
1864 ScriptRuleCocciInfo
(r) ->
1865 if List.mem
r.language languages
then
1868 r.language
::languages
1873 let rlang = r.language
in
1874 let rname = r.scr_rule_info
.rulename
in
1876 let _ = List.assoc
(rlang,rname) !Iteration.initialization_stack
in
1880 Iteration.initialization_stack
:=
1881 ((rlang,rname),!Flag.defined_virtual_rules
) ::
1882 !Iteration.initialization_stack
;
1883 initial_final_bigloop Initial
1884 (fun (x
,_,_,y
) -> fun deps ->
1885 Ast_cocci.InitialScriptRule
(rname,x
,deps,y
))
1889 let initialized_languages =
1891 (function languages
->
1893 InitialScriptRuleCocciInfo
(r) ->
1894 let rlang = r.language
in
1895 (if List.mem
rlang languages
1896 then failwith
("double initializer found for "^
rlang));
1897 if interpret_dependencies [] [] r.scr_rule_info
.dependencies
1898 then begin runrule r; rlang::languages
end
1903 let uninitialized_languages =
1905 (fun used
-> not
(List.mem used
initialized_languages))
1912 dependencies
= Ast_cocci.NoDep
;
1915 was_matched
= ref false;} in
1916 runrule (make_init lgg
"" rule_info))
1917 uninitialized_languages;
1922 Common.profile_code
"pre_engine" (fun () -> pre_engine2 a
)
1924 let full_engine2 (cocci_infos,toks
) cfiles =
1926 show_or_not_cfiles cfiles;
1928 (* optimisation allowing to launch coccinelle on all the drivers *)
1929 if !Flag_cocci.worth_trying_opt
&& not
(worth_trying cfiles toks
)
1935 pr2
("No matches found for " ^
(Common.join
" " toks
)
1936 ^
"\nSkipping:" ^
(Common.join
" " cfiles)));
1937 cfiles +> List.map
(fun s -> s, None
)
1942 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1943 if !Flag.show_misc
then pr
"let's go";
1944 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1946 if !Flag_cocci.show_binding_in_out
1949 (match !Flag.defined_virtual_rules
with
1951 | l -> pr
(Printf.sprintf
"Defined virtual rules: %s"
1952 (String.concat
" " l)));
1955 pr
(Printf.sprintf
"%s = %s" v vl
))
1956 !Flag.defined_virtual_env
;
1957 Common.pr_xxxxxxxxxxxxxxxxx
()
1960 let choose_includes =
1961 match !Flag_cocci.include_options
with
1962 Flag_cocci.I_UNSPECIFIED
->
1963 if !g_contain_typedmetavar
1964 then Flag_cocci.I_NORMAL_INCLUDES
1965 else Flag_cocci.I_NO_INCLUDES
1967 let c_infos = prepare_c cfiles choose_includes in
1969 (* ! the big loop ! *)
1970 let c_infos'
= bigloop cocci_infos c_infos in
1972 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1973 if !Flag.show_misc
then pr
"Finished";
1974 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1975 if !Flag_ctl.graphical_trace
then gen_pdf_graph ();
1977 c_infos'
+> List.map
(fun c_or_h
->
1978 if !(c_or_h
.was_modified_once
)
1982 Common.new_temp_file
"cocci-output" ("-" ^ c_or_h
.fname
) in
1984 if c_or_h
.fkind
=*= Header
1985 then pr2
("a header file was modified: " ^ c_or_h
.fname
);
1987 (* and now unparse everything *)
1988 cfile_of_program (for_unparser c_or_h
.asts
) outfile;
1990 show_or_not_diff c_or_h
.fpath
outfile;
1993 if !Flag.sgrep_mode2
then None
else Some
outfile)
1995 else (c_or_h
.fpath
, None
))
1998 let full_engine a b
=
1999 Common.profile_code
"full_engine"
2000 (fun () -> let res = full_engine2 a b
in (*Gc.print_stat stderr; *)res)
2002 let post_engine2 (cocci_infos,_) =
2004 (function ((language
,_),virt_rules
) ->
2005 Flag.defined_virtual_rules
:= virt_rules
;
2008 (function languages
->
2010 FinalScriptRuleCocciInfo
(r) ->
2011 (if r.language
= language
&& List.mem
r.language languages
2012 then failwith
("double finalizer found for "^
r.language
));
2013 initial_final_bigloop Final
2014 (fun (x
,_,_,y
) -> fun deps ->
2015 Ast_cocci.FinalScriptRule
(r.scr_rule_info
.rulename
,
2018 r.language
::languages
2022 !Iteration.initialization_stack
2025 Common.profile_code
"post_engine" (fun () -> post_engine2 a
)
2027 (*****************************************************************************)
2028 (* check duplicate from result of full_engine *)
2029 (*****************************************************************************)
2031 let check_duplicate_modif2 xs =
2032 (* opti: let groups = Common.groupBy (fun (a,resa) (b,resb) -> a =$= b) xs *)
2033 if !Flag_cocci.verbose_cocci
2034 then pr2
("Check duplication for " ^ i_to_s
(List.length
xs) ^
" files");
2036 let groups = Common.group_assoc_bykey_eff
xs in
2037 groups +> Common.map_filter
(fun (file, xs) ->
2039 | [] -> raise
(Impossible
162)
2040 | [res] -> Some
(file, res)
2044 if not
(List.for_all
(fun res2
-> res2
=*= None
) xs)
2046 pr2
("different modification result for " ^
file);
2049 else Some
(file, None
)
2051 if not
(List.for_all
(fun res2
->
2055 let diff = Common.cmd_to_list
("diff -u -b -B "^
res^
" "^res2
)
2059 pr2
("different modification result for " ^
file);
2062 else Some
(file, Some
res)
2064 let check_duplicate_modif a
=
2065 Common.profile_code
"check_duplicate" (fun () -> check_duplicate_modif2 a
)