2 * Copyright 2010, INRIA, University of Copenhagen
3 * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
4 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
5 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
6 * This file is part of Coccinelle.
8 * Coccinelle is free software: you can redistribute it and/or modify
9 * it under the terms of the GNU General Public License as published by
10 * the Free Software Foundation, according to version 2 of the License.
12 * Coccinelle is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 * GNU General Public License for more details.
17 * You should have received a copy of the GNU General Public License
18 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
20 * The authors reserve the right to distribute this or future versions of
21 * Coccinelle under other licenses.
27 module CCI
= Ctlcocci_integration
28 module TAC
= Type_annoter_c
30 module Ast_to_flow
= Control_flow_c_build
32 (*****************************************************************************)
33 (* This file is a kind of driver. It gathers all the important functions
34 * from coccinelle in one place. The different entities in coccinelle are:
38 * - flow (contain nodes)
39 * - ctl (contain rule_elems)
40 * This file contains functions to transform one in another.
42 (*****************************************************************************)
44 (* --------------------------------------------------------------------- *)
46 (* --------------------------------------------------------------------- *)
47 let cprogram_of_file file
=
48 let (program2
, _stat
) = Parse_c.parse_c_and_cpp file
in
51 let cprogram_of_file_cached file
=
52 let (program2
, _stat
) = Parse_c.parse_cache file
in
53 if !Flag_cocci.ifdef_to_if
55 program2
+> Parse_c.with_program2
(fun asts
->
56 Cpp_ast_c.cpp_ifdef_statementize asts
60 let cfile_of_program program2_with_ppmethod outf
=
61 Unparse_c.pp_program program2_with_ppmethod outf
63 (* for memoization, contains only one entry, the one for the SP *)
64 let _hparse = Hashtbl.create
101
65 let _h_ocaml_init = Hashtbl.create
101
66 let _hctl = Hashtbl.create
101
68 (* --------------------------------------------------------------------- *)
70 (* --------------------------------------------------------------------- *)
71 (* for a given pair (file,iso), only keep an instance for the most recent
72 virtual rules and virtual_env *)
74 let sp_of_file2 file iso
=
77 let (_
,xs
,_
,_
,_
,_
,_
) as res
= Parse_cocci.process file iso
false in
78 (* if there is already a compiled ML code, do nothing and use that *)
79 try let _ = Hashtbl.find
_h_ocaml_init (file
,iso
) in res
82 Hashtbl.add
_h_ocaml_init (file
,iso
) ();
83 match Prepare_ocamlcocci.prepare file xs
with
85 | Some ocaml_script_file
->
87 Prepare_ocamlcocci.load_file ocaml_script_file
;
88 (if not
!Common.save_tmp_files
89 then Prepare_ocamlcocci.clean_file ocaml_script_file
);
92 Hashtbl.add
_hparse (file
,iso
)
93 (!Flag.defined_virtual_rules
,!Flag.defined_virtual_env
,new_code);
96 let (rules
,env
,code
) = Hashtbl.find
_hparse (file
,iso
) in
97 if rules
= !Flag.defined_virtual_rules
&& env
= !Flag.defined_virtual_env
99 else (Hashtbl.remove
_hparse (file
,iso
); redo())
100 with Not_found
-> redo()
102 let sp_of_file file iso
=
103 Common.profile_code
"parse cocci" (fun () -> sp_of_file2 file iso
)
106 (* --------------------------------------------------------------------- *)
108 (* --------------------------------------------------------------------- *)
109 let print_flow flow
=
110 Ograph_extended.print_ograph_mutable flow
"/tmp/test.dot" true
113 let ast_to_flow_with_error_messages2 x
=
115 try Ast_to_flow.ast_to_control_flow x
116 with Ast_to_flow.Error x
->
117 Ast_to_flow.report_error x
;
120 flowopt +> do_option
(fun flow
->
121 (* This time even if there is a deadcode, we still have a
122 * flow graph, so I can try the transformation and hope the
123 * deadcode will not bother us.
125 try Ast_to_flow.deadcode_detection flow
126 with Ast_to_flow.Error
(Ast_to_flow.DeadCode x
) ->
127 Ast_to_flow.report_error
(Ast_to_flow.DeadCode x
);
130 let ast_to_flow_with_error_messages a
=
131 Common.profile_code
"flow" (fun () -> ast_to_flow_with_error_messages2 a
)
134 (* --------------------------------------------------------------------- *)
136 (* --------------------------------------------------------------------- *)
138 let ctls_of_ast2 ast
(ua
,fua
,fuas
) pos
=
140 (function ast
-> function (ua
,(fua
,(fuas
,pos
))) ->
144 else Asttoctl2.asttoctl ast
(ua
,fua
,fuas
) pos
)
145 (Asttomember.asttomember ast ua
))
146 ast
(List.combine ua
(List.combine fua
(List.combine fuas pos
)))
148 let ctls_of_ast ast ua
=
149 Common.profile_code
"asttoctl2" (fun () -> ctls_of_ast2 ast ua
)
151 (*****************************************************************************)
152 (* Some debugging functions *)
153 (*****************************************************************************)
157 let show_or_not_cfile2 cfile
=
158 if !Flag_cocci.show_c
then begin
159 Common.pr2_xxxxxxxxxxxxxxxxx
();
160 pr2
("processing C file: " ^ cfile
);
161 Common.pr2_xxxxxxxxxxxxxxxxx
();
162 Common.command2
("cat " ^ cfile
);
164 let show_or_not_cfile a
=
165 Common.profile_code
"show_xxx" (fun () -> show_or_not_cfile2 a
)
167 let show_or_not_cfiles cfiles
= List.iter
show_or_not_cfile cfiles
170 let show_or_not_cocci2 coccifile isofile
=
171 if !Flag_cocci.show_cocci
then begin
172 Common.pr2_xxxxxxxxxxxxxxxxx
();
173 pr2
("processing semantic patch file: " ^ coccifile
);
174 isofile
+> (fun s
-> pr2
("with isos from: " ^ s
));
175 Common.pr2_xxxxxxxxxxxxxxxxx
();
176 Common.command2
("cat " ^ coccifile
);
179 let show_or_not_cocci a b
=
180 Common.profile_code
"show_xxx" (fun () -> show_or_not_cocci2 a b
)
182 (* ---------------------------------------------------------------------- *)
185 let fix_sgrep_diffs l
=
187 List.filter
(function s
-> (s
=~
"^\\+\\+\\+") || not
(s
=~
"^\\+")) l in
188 let l = List.rev
l in
189 (* adjust second number for + code *)
190 let rec loop1 n
= function
193 if s
=~
"^-" && not
(s
=~
"^---")
194 then s
:: loop1 (n
+1) ss
197 (match Str.split
(Str.regexp
" ") s
with
200 match Str.split
(Str.regexp
",") pl
with
203 | _ -> failwith
"bad + line information" in
204 let n2 = int_of_string
n2 in
205 (Printf.sprintf
"%s %s %s,%d %s" bef min n1
(n2-n
)
206 (String.concat
" " aft
))
208 | _ -> failwith
"bad @@ information")
209 else s
:: loop1 n ss
in
210 let rec loop2 n
= function
217 (match Str.split
(Str.regexp
" ") s
with
220 match (Str.split
(Str.regexp
",") min
,
221 Str.split
(Str.regexp
",") pl
) with
222 ([_;m2
],[n1
;n2]) -> (m2
,n1
,n2)
223 | ([_],[n1
;n2]) -> ("1",n1
,n2)
224 | ([_;m2
],[n1
]) -> (m2
,n1
,"1")
225 | ([_],[n1
]) -> ("1",n1
,"1")
226 | _ -> failwith
"bad -/+ line information" in
228 int_of_string
(String.sub
n1 1 ((String.length
n1)-1)) in
229 let m2 = int_of_string
m2 in
230 let n2 = int_of_string
n2 in
231 (Printf.sprintf
"%s %s +%d,%d %s" bef min
(n1-n
) n2
232 (String.concat
" " aft
))
233 :: loop2 (n
+(m2-n2)) ss
234 | _ -> failwith
"bad @@ information")
235 else s
:: loop2 n ss
in
236 loop2 0 (List.rev
(loop1 0 l))
238 let normalize_path file
=
240 if String.get file
0 = '
/'
then file
else (Sys.getcwd
()) ^
"/" ^ file
in
241 let elements = Str.split_delim
(Str.regexp
"/") fullpath in
242 let rec loop prev
= function
243 [] -> String.concat
"/" (List.rev prev
)
244 | "." :: rest
-> loop prev rest
247 x
::xs
-> loop xs rest
248 | _ -> failwith
"bad path")
249 | x
::rest
-> loop (x
::prev
) rest
in
252 let show_or_not_diff2 cfile outfile
=
253 if !Flag_cocci.show_diff
then begin
254 match Common.fst
(Compare_c.compare_to_original cfile outfile
) with
255 Compare_c.Correct
-> () (* diff only in spacing, etc *)
257 (* may need --strip-trailing-cr under windows *)
261 match !Flag_parsing_c.diff_lines
with
262 | None
-> "diff -u -p " ^ cfile ^
" " ^ outfile
263 | Some n
-> "diff -U "^n^
" -p "^cfile^
" "^outfile
in
265 let res = Common.cmd_to_list
line in
266 match (!Flag.patch
,res) with
267 (* create something that looks like the output of patch *)
268 (Some prefix
,minus_file
::plus_file
::rest
) ->
270 let lp = String.length
prefix in
271 if String.get
prefix (lp-1) = '
/'
272 then String.sub
prefix 0 (lp-1)
274 let drop_prefix file
=
275 let file = normalize_path file in
276 if Str.string_match
(Str.regexp
prefix) file 0
278 let lp = String.length
prefix in
279 let lf = String.length
file in
281 then String.sub
file lp (lf - lp)
284 (Printf.sprintf
"prefix %s doesn't match file %s"
288 (Printf.sprintf
"prefix %s doesn't match file %s"
291 match List.rev
(Str.split
(Str.regexp
" ") line) with
292 new_file
::old_file
::cmdrev
->
293 let old_base_file = drop_prefix old_file
in
298 (("/tmp/nothing"^
old_base_file)
299 :: old_file
:: cmdrev
))
303 (("b"^
old_base_file)::("a"^
old_base_file)::cmdrev
))
304 | _ -> failwith
"bad command" in
305 let (minus_line
,plus_line
) =
306 match (Str.split
(Str.regexp
"[ \t]") minus_file
,
307 Str.split
(Str.regexp
"[ \t]") plus_file
) with
308 ("---"::old_file
::old_rest
,"+++"::new_file
::new_rest
) ->
309 let old_base_file = drop_prefix old_file
in
311 then (minus_file
,"+++ /tmp/nothing"^
old_base_file)
314 ("---"::("a"^
old_base_file)::old_rest
),
316 ("+++"::("b"^
old_base_file)::new_rest
))
319 (Printf.sprintf
"bad diff header lines: %s %s"
320 (String.concat
":" l1
) (String.concat
":" l2
)) in
321 diff_line::minus_line
::plus_line
::rest
323 let xs = if !Flag.sgrep_mode2
then fix_sgrep_diffs xs else xs in
326 let show_or_not_diff a b
=
327 Common.profile_code
"show_xxx" (fun () -> show_or_not_diff2 a b
)
330 (* the derived input *)
332 let show_or_not_ctl_tex2 astcocci ctls
=
333 if !Flag_cocci.show_ctl_tex
then begin
334 Ctltotex.totex
("/tmp/__cocci_ctl.tex") astcocci ctls
;
335 Common.command2
("cd /tmp; latex __cocci_ctl.tex; " ^
336 "dvips __cocci_ctl.dvi -o __cocci_ctl.ps;" ^
337 "gv __cocci_ctl.ps &");
339 let show_or_not_ctl_tex a b
=
340 Common.profile_code
"show_xxx" (fun () -> show_or_not_ctl_tex2 a b
)
343 let show_or_not_rule_name ast rulenb
=
344 if !Flag_cocci.show_ctl_text
or !Flag.show_trying
or
345 !Flag.show_transinfo
or !Flag_cocci.show_binding_in_out
350 Ast_cocci.CocciRule
(nm
, (deps
, drops
, exists
), x
, _, _) -> nm
351 | _ -> i_to_s rulenb
in
352 Common.pr_xxxxxxxxxxxxxxxxx
();
354 Common.pr_xxxxxxxxxxxxxxxxx
()
357 let show_or_not_scr_rule_name rulenb
=
358 if !Flag_cocci.show_ctl_text
or !Flag.show_trying
or
359 !Flag.show_transinfo
or !Flag_cocci.show_binding_in_out
362 let name = i_to_s rulenb
in
363 Common.pr_xxxxxxxxxxxxxxxxx
();
364 pr
("script rule " ^
name ^
" = ");
365 Common.pr_xxxxxxxxxxxxxxxxx
()
368 let show_or_not_ctl_text2 ctl ast rulenb
=
369 if !Flag_cocci.show_ctl_text
then begin
371 adjust_pp_with_indent
(fun () ->
372 Format.force_newline
();
373 Pretty_print_cocci.print_plus_flag
:= true;
374 Pretty_print_cocci.print_minus_flag
:= true;
375 Pretty_print_cocci.unparse ast
;
380 adjust_pp_with_indent
(fun () ->
381 Format.force_newline
();
382 Pretty_print_engine.pp_ctlcocci
383 !Flag_cocci.show_mcodekind_in_ctl
!Flag_cocci.inline_let_ctl ctl
;
387 let show_or_not_ctl_text a b c
=
388 Common.profile_code
"show_xxx" (fun () -> show_or_not_ctl_text2 a b c
)
392 (* running information *)
393 let get_celem celem
: string =
395 Ast_c.Definition
({Ast_c.f_name
= namefuncs
;},_) ->
396 Ast_c.str_of_name namefuncs
398 (Ast_c.DeclList
([{Ast_c.v_namei
= Some
(name, _);}, _], _)) ->
399 Ast_c.str_of_name
name
402 let show_or_not_celem2 prelude celem
=
405 | Ast_c.Definition
({Ast_c.f_name
= namefuncs
},_) ->
406 let funcs = Ast_c.str_of_name namefuncs
in
407 Flag.current_element
:= funcs;
408 (" function: ",funcs)
410 (Ast_c.DeclList
([{Ast_c.v_namei
= Some
(name,_)}, _], _)) ->
411 let s = Ast_c.str_of_name
name in
412 Flag.current_element
:= s;
415 Flag.current_element
:= "something_else";
416 (" ","something else");
418 if !Flag.show_trying
then pr2
(prelude ^ tag ^ trying
)
420 let show_or_not_celem a b
=
421 Common.profile_code
"show_xxx" (fun () -> show_or_not_celem2 a b
)
424 let show_or_not_trans_info2 trans_info
=
425 (* drop witness tree indices for printing *)
427 List.map
(function (index
,trans_info) -> trans_info) trans_info in
428 if !Flag.show_transinfo
then begin
429 if null
trans_info then pr2
"transformation info is empty"
431 pr2
"transformation info returned:";
433 List.sort
(function (i1
,_,_) -> function (i2
,_,_) -> compare i1 i2
)
437 trans_info +> List.iter
(fun (i
, subst
, re
) ->
438 pr2
("transform state: " ^
(Common.i_to_s i
));
440 adjust_pp_with_indent_and_header
"with rule_elem: " (fun () ->
441 Pretty_print_cocci.print_plus_flag
:= true;
442 Pretty_print_cocci.print_minus_flag
:= true;
443 Pretty_print_cocci.rule_elem
"" re
;
445 adjust_pp_with_indent_and_header
"with binding: " (fun () ->
446 Pretty_print_engine.pp_binding subst
;
453 let show_or_not_trans_info a
=
454 Common.profile_code
"show_xxx" (fun () -> show_or_not_trans_info2 a
)
458 let show_or_not_binding2 s binding
=
459 if !Flag_cocci.show_binding_in_out
then begin
460 adjust_pp_with_indent_and_header
("binding " ^
s ^
" = ") (fun () ->
461 Pretty_print_engine.pp_binding binding
464 let show_or_not_binding a b
=
465 Common.profile_code
"show_xxx" (fun () -> show_or_not_binding2 a b
)
469 (*****************************************************************************)
470 (* Some helper functions *)
471 (*****************************************************************************)
473 let worth_trying cfiles tokens
=
474 (* drop the following line for a list of list by rules. since we don't
475 allow multiple minirules, all the tokens within a rule should be in
476 a single CFG entity *)
477 match (!Flag_cocci.windows
,tokens
) with
478 (true,_) | (_,None
) -> true
480 (* could also modify the code in get_constants.ml *)
481 let tokens = tokens +> List.map
(fun s ->
483 | _ when s =~
"^[A-Za-z_][A-Za-z_0-9]*$" ->
486 | _ when s =~
"^[A-Za-z_]" ->
489 | _ when s =~
".*[A-Za-z_]$" ->
494 let com = sprintf
"egrep -q '(%s)' %s" (join
"|" tokens) (join
" " cfiles
)
496 (match Sys.command
com with
497 | 0 (* success *) -> true
500 then Printf.printf
"grep failed: %s\n" com);
501 false (* no match, so not worth trying *))
503 let check_macro_in_sp_and_adjust = function
506 tokens +> List.iter
(fun s ->
507 if Hashtbl.mem
!Parse_c._defs
s
509 if !Flag_cocci.verbose_cocci
then begin
510 pr2
"warning: macro in semantic patch was in macro definitions";
511 pr2
("disabling macro expansion for " ^
s);
513 Hashtbl.remove
!Parse_c._defs
s
517 let contain_loop gopt
=
520 g#nodes#tolist
+> List.exists
(fun (xi
, node
) ->
521 Control_flow_c.extract_is_loop node
523 | None
-> true (* means nothing, if no g then will not model check *)
527 let sp_contain_typed_metavar_z toplevel_list_list
=
528 let bind x y
= x
or y
in
529 let option_default = false in
530 let mcode _ _ = option_default in
531 let donothing r k e
= k e
in
533 let expression r k e
=
534 match Ast_cocci.unwrap e
with
535 | Ast_cocci.MetaExpr
(_,_,_,Some t
,_,_) -> true
536 | Ast_cocci.MetaExpr
(_,_,_,_,Ast_cocci.LocalID
,_) -> true
541 Visitor_ast.combiner bind option_default
542 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
543 donothing donothing donothing donothing donothing
544 donothing expression donothing donothing donothing donothing donothing
545 donothing donothing donothing donothing donothing
547 toplevel_list_list
+>
549 (function (nm
,_,rule
) ->
550 (List.exists
combiner.Visitor_ast.combiner_top_level rule
))
552 let sp_contain_typed_metavar rules
=
553 sp_contain_typed_metavar_z
557 Ast_cocci.CocciRule
(a
,b
,c
,d
,_) -> (a
,b
,c
)
558 | _ -> failwith
"error in filter")
562 Ast_cocci.CocciRule
(a
,b
,c
,d
,Ast_cocci.Normal
) -> true
568 (* finding among the #include the one that we need to parse
569 * because they may contain useful type definition or because
570 * we may have to modify them
572 * For the moment we base in part our heuristic on the name of the file, e.g.
573 * serio.c is related we think to #include <linux/serio.h>
575 let include_table = Hashtbl.create
(100)
577 let interpret_include_path relpath
=
578 let maxdepth = List.length relpath
in
579 let unique_file_exists dir f
=
581 Printf.sprintf
"find %s -maxdepth %d -mindepth %d -path \"*/%s\""
582 dir
maxdepth maxdepth f
in
583 match Common.cmd_to_list
cmd with
586 let native_file_exists dir f
=
587 let f = Filename.concat dir
f in
591 let rec search_include_path exists searchlist relpath
=
592 match searchlist
with
595 (match exists hd relpath
with
597 | None
-> search_include_path exists tail relpath
) in
598 let rec search_path exists searchlist
= function
600 let res = Common.concat
"/" relpath
in
601 Hashtbl.add
include_table (searchlist
,relpath
) res;
603 | (hd
::tail
) as relpath1
->
604 let relpath1 = Common.concat
"/" relpath1 in
605 (match search_include_path exists searchlist
relpath1 with
606 None
-> search_path unique_file_exists searchlist tail
608 Hashtbl.add
include_table (searchlist
,relpath
) f;
611 match !Flag_cocci.include_path
with
614 try Some
(Hashtbl.find
include_table (searchlist,relpath
))
616 search_path native_file_exists searchlist relpath
618 let (includes_to_parse
:
619 (Common.filename
* Parse_c.program2
) list
->
620 Flag_cocci.include_options
-> 'a
) = fun xs choose_includes
->
621 match choose_includes
with
622 Flag_cocci.I_UNSPECIFIED
-> failwith
"not possible"
623 | Flag_cocci.I_NO_INCLUDES
-> []
627 [Flag_cocci.I_ALL_INCLUDES
; Flag_cocci.I_REALLY_ALL_INCLUDES
] in
628 xs +> List.map
(fun (file, cs
) ->
629 let dir = Common.dirname
file in
631 cs
+> Common.map_filter
(fun (c
,_info_item
) ->
635 {Ast_c.i_include
= ((x
,ii
)); i_rel_pos
= info_h_pos
;}) ->
638 let relpath = Common.join
"/" xs in
639 let f = Filename.concat
dir relpath in
640 if (Sys.file_exists
f) then
643 if !Flag_cocci.relax_include_path
644 (* for our tests, all the files are flat in the current dir *)
646 let attempt2 = Filename.concat
dir (Common.last
xs) in
647 if not
(Sys.file_exists
attempt2) && all_includes
649 interpret_include_path xs
652 if all_includes then interpret_include_path xs
655 | Ast_c.NonLocal
xs ->
657 Common.fileprefix
(Common.last
xs) =$
= Common.fileprefix
file
659 interpret_include_path xs
661 | Ast_c.Weird
_ -> None
665 +> (fun x
-> (List.rev
(Common.uniq
(List.rev x
)))) (*uniq keeps last*)
667 let rec interpret_dependencies local global
= function
668 Ast_cocci.Dep
s -> List.mem
s local
669 | Ast_cocci.AntiDep
s ->
670 (if !Flag_ctl.steps
!= None
671 then failwith
"steps and ! dependency incompatible");
672 not
(List.mem
s local
)
673 | Ast_cocci.EverDep
s -> List.mem
s global
674 | Ast_cocci.NeverDep
s ->
675 (if !Flag_ctl.steps
!= None
676 then failwith
"steps and ! dependency incompatible");
677 not
(List.mem
s global
)
678 | Ast_cocci.AndDep
(s1
,s2
) ->
679 (interpret_dependencies local global s1
) &&
680 (interpret_dependencies local global s2
)
681 | Ast_cocci.OrDep
(s1
,s2
) ->
682 (interpret_dependencies local global s1
) or
683 (interpret_dependencies local global s2
)
684 | Ast_cocci.NoDep
-> true
685 | Ast_cocci.FailDep
-> false
687 let rec print_dependencies str local global dep
=
688 if !Flag_cocci.show_dependencies
693 let rec loop = function
694 Ast_cocci.Dep
s | Ast_cocci.AntiDep
s ->
695 if not
(List.mem
s !seen)
699 then pr2
(s^
" satisfied")
700 else pr2
(s^
" not satisfied");
703 | Ast_cocci.EverDep
s | Ast_cocci.NeverDep
s ->
704 if not
(List.mem
s !seen)
708 then pr2
(s^
" satisfied")
709 else pr2
(s^
" not satisfied");
712 | Ast_cocci.AndDep
(s1
,s2
) ->
715 | Ast_cocci.OrDep
(s1
,s2
) ->
718 | Ast_cocci.NoDep
-> ()
719 | Ast_cocci.FailDep
-> pr2
"False not satisfied" in
723 (* --------------------------------------------------------------------- *)
724 (* #include relative position in the file *)
725 (* --------------------------------------------------------------------- *)
727 (* compute the set of new prefixes
729 * "a/b/x"; (* in fact it is now a list of string so ["a";"b";"x"] *)
733 * it would give
for the first element
734 * ""; "a"; "a/b"; "a/b/x"
738 * update
: if the
include is inside a ifdef a put nothing
. cf
-test incl
.
739 * this is because we dont want code added inside ifdef
.
742 let compute_new_prefixes xs =
743 xs +> Common.map_withenv
(fun already
xs ->
744 let subdirs_prefixes = Common.inits
xs in
745 let new_first = subdirs_prefixes +> List.filter
(fun x
->
746 not
(List.mem x already
)
755 (* does via side effect on the ref in the Include in Ast_c *)
756 let rec update_include_rel_pos cs
=
757 let only_include = cs
+> Common.map_filter
(fun c
->
759 | Ast_c.CppTop
(Ast_c.Include
{Ast_c.i_include
= ((x
,_));
761 i_is_in_ifdef
= inifdef
}) ->
763 | Ast_c.Weird
_ -> None
772 let (locals
, nonlocals
) =
773 only_include +> Common.partition_either
(fun (c
, aref
) ->
775 | Ast_c.Local x
-> Left
(x
, aref
)
776 | Ast_c.NonLocal x
-> Right
(x
, aref
)
777 | Ast_c.Weird x
-> raise Impossible
780 update_rel_pos_bis locals
;
781 update_rel_pos_bis nonlocals
;
783 and update_rel_pos_bis
xs =
784 let xs'
= List.map fst
xs in
785 let the_first = compute_new_prefixes xs'
in
786 let the_last = List.rev
(compute_new_prefixes (List.rev
xs'
)) in
787 let merged = Common.zip
xs (Common.zip
the_first the_last) in
788 merged +> List.iter
(fun ((x
, aref
), (the_first, the_last)) ->
791 Ast_c.first_of
= the_first;
792 Ast_c.last_of
= the_last;
797 (*****************************************************************************)
798 (* All the information needed around the C elements and Cocci rules *)
799 (*****************************************************************************)
801 type toplevel_c_info
= {
802 ast_c
: Ast_c.toplevel
; (* contain refs so can be modified *)
803 tokens_c
: Parser_c.token list
;
806 flow
: Control_flow_c.cflow
option; (* it's the "fixed" flow *)
809 env_typing_before
: TAC.environment
;
810 env_typing_after
: TAC.environment
;
812 was_modified
: bool ref;
819 dependencies
: Ast_cocci.dependency
;
820 used_after
: Ast_cocci.meta_name list
;
822 was_matched
: bool ref;
825 type toplevel_cocci_info_script_rule
= {
828 (Ast_cocci.script_meta_name
* Ast_cocci.meta_name
*
829 Ast_cocci.metavar
) list
*
830 Ast_cocci.meta_name list
(*fresh vars*) *
834 scr_rule_info
: rule_info
;
837 type toplevel_cocci_info_cocci_rule
= {
838 ctl
: Lib_engine.ctlcocci
* (CCI.pred list list
);
839 metavars
: Ast_cocci.metavar list
;
840 ast_rule
: Ast_cocci.rule
;
841 isexp
: bool; (* true if + code is an exp, only for Flag.make_hrule *)
843 (* There are also some hardcoded rule names in parse_cocci.ml:
844 * let reserved_names = ["all";"optional_storage";"optional_qualifier"]
846 dropped_isos
: string list
;
847 free_vars
: Ast_cocci.meta_name list
;
848 negated_pos_vars
: Ast_cocci.meta_name list
;
849 positions
: Ast_cocci.meta_name list
;
851 ruletype
: Ast_cocci.ruletype
;
853 rule_info
: rule_info
;
856 type toplevel_cocci_info
=
857 ScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
858 | InitialScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
859 | FinalScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
860 | CocciRuleCocciInfo
of toplevel_cocci_info_cocci_rule
862 type cocci_info
= toplevel_cocci_info list
* string list
option (* tokens *)
864 type kind_file
= Header
| Source
868 was_modified_once
: bool ref;
869 asts
: toplevel_c_info list
;
874 let g_contain_typedmetavar = ref false
877 let last_env_toplevel_c_info xs =
878 (Common.last
xs).env_typing_after
880 let concat_headers_and_c (ccs
: file_info list
)
881 : (toplevel_c_info
* string) list
=
882 (List.concat
(ccs
+> List.map
(fun x
->
883 x
.asts
+> List.map
(fun x'
->
886 let for_unparser xs =
887 xs +> List.map
(fun x
->
888 (x
.ast_c
, (x
.fullstring
, x
.tokens_c
)), Unparse_c.PPviastr
891 let gen_pdf_graph () =
892 (Ctl_engine.get_graph_files
()) +> List.iter
(fun outfile
->
893 Printf.printf
"Generation of %s%!" outfile
;
894 let filename_stack = Ctl_engine.get_graph_comp_files outfile
in
895 List.iter
(fun filename
->
896 ignore
(Unix.system
("dot " ^ filename ^
" -Tpdf -o " ^ filename ^
".pdf;"))
898 let (head
,tail
) = (List.hd
filename_stack, List.tl
filename_stack) in
899 ignore
(Unix.system
("cp " ^ head ^
".pdf " ^ outfile ^
".pdf;"));
900 tail
+> List.iter
(fun filename
->
901 ignore
(Unix.system
("mv " ^ outfile ^
".pdf /tmp/tmp.pdf;"));
902 ignore
(Unix.system
("pdftk " ^ filename ^
".pdf /tmp/tmp.pdf cat output " ^ outfile ^
".pdf"));
904 ignore
(Unix.system
("rm /tmp/tmp.pdf;"));
905 List.iter
(fun filename
->
906 ignore
(Unix.system
("rm " ^ filename ^
" " ^ filename ^
".pdf;"))
908 Printf.printf
" - Done\n")
910 let local_python_code =
911 "from coccinelle import *\n"
914 "import coccinelle\n"^
916 "import coccilib.org\n"^
917 "import coccilib.report\n" ^
921 let make_init lang code rule_info
=
924 scr_ast_rule
= (lang
, mv, [], code
);
926 script_code
= (if lang
= "python" then python_code else "") ^code
;
927 scr_rule_info
= rule_info
;
930 (* --------------------------------------------------------------------- *)
931 let prepare_cocci ctls free_var_lists negated_pos_lists
932 (ua
,fua
,fuas
) positions_list metavars astcocci
=
934 let gathered = Common.index_list_1
935 (zip
(zip
(zip
(zip
(zip
(zip
(zip
(zip ctls metavars
) astcocci
)
937 negated_pos_lists
) ua
) fua
) fuas
) positions_list
)
940 (fun (((((((((ctl_toplevel_list
,metavars
),ast
),free_var_list
),
941 negated_pos_list
),ua
),fua
),fuas
),positions_list
),rulenb
) ->
943 let build_rule_info rulename deps
=
944 {rulename
= rulename
;
946 used_after
= (List.hd ua
) @ (List.hd fua
);
948 was_matched
= ref false;} in
950 let is_script_rule r
=
952 Ast_cocci.ScriptRule
_
953 | Ast_cocci.InitialScriptRule
_ | Ast_cocci.FinalScriptRule
_ -> true
956 if not
(List.length ctl_toplevel_list
=|= 1) && not
(is_script_rule ast
)
957 then failwith
"not handling multiple minirules";
960 Ast_cocci.ScriptRule
(name,lang
,deps
,mv,script_vars
,code
) ->
963 scr_ast_rule
= (lang
, mv, script_vars
, code
);
966 scr_rule_info
= build_rule_info name deps
;
968 in ScriptRuleCocciInfo
r
969 | Ast_cocci.InitialScriptRule
(name,lang
,deps
,code
) ->
970 let r = make_init lang code
(build_rule_info name deps
) in
971 InitialScriptRuleCocciInfo
r
972 | Ast_cocci.FinalScriptRule
(name,lang
,deps
,code
) ->
976 scr_ast_rule
= (lang
, mv, [], code
);
979 scr_rule_info
= build_rule_info name deps
;
981 in FinalScriptRuleCocciInfo
r
982 | Ast_cocci.CocciRule
983 (rulename
,(dependencies
,dropped_isos
,z
),restast
,isexp
,ruletype
) ->
986 ctl
= List.hd ctl_toplevel_list
;
989 isexp
= List.hd isexp
;
990 dropped_isos
= dropped_isos
;
991 free_vars
= List.hd free_var_list
;
992 negated_pos_vars
= List.hd negated_pos_list
;
993 positions
= List.hd positions_list
;
995 rule_info
= build_rule_info rulename dependencies
;
999 (* --------------------------------------------------------------------- *)
1001 let build_info_program cprogram env
=
1003 let (cs
, parseinfos
) =
1004 Common.unzip cprogram
in
1007 parseinfos
+> List.map
(fun (s,toks
) -> toks
) +> List.flatten
in
1009 (* I use cs' but really annotate_xxx work by doing side effects on cs *)
1011 Comment_annotater_c.annotate_program
alltoks cs in
1013 Type_annoter_c.annotate_program env
(*!g_contain_typedmetavar*) cs'
1016 zip
cs_with_envs parseinfos
+> List.map
(fun ((c
, (enva
,envb
)), parseinfo
)->
1017 let (fullstr
, tokens) = parseinfo
in
1020 ast_to_flow_with_error_messages c
+>
1021 Common.map_option
(fun flow ->
1022 let flow = Ast_to_flow.annotate_loop_nodes
flow in
1024 (* remove the fake nodes for julia *)
1025 let fixed_flow = CCI.fix_flow_ctl
flow in
1027 if !Flag_cocci.show_flow
then print_flow fixed_flow;
1028 if !Flag_cocci.show_before_fixed_flow
then print_flow flow;
1035 ast_c
= c
; (* contain refs so can be modified *)
1037 fullstring
= fullstr
;
1041 contain_loop = contain_loop flow;
1043 env_typing_before
= enva
;
1044 env_typing_after
= envb
;
1046 was_modified
= ref false;
1052 (* Optimisation. Try not unparse/reparse the whole file when have modifs *)
1053 let rebuild_info_program cs file isexp
=
1054 cs +> List.map
(fun c
->
1055 if !(c
.was_modified
)
1057 let file = Common.new_temp_file
"cocci_small_output" ".c" in
1059 [(c
.ast_c
, (c
.fullstring
, c
.tokens_c
)), Unparse_c.PPnormal
]
1062 (* Common.command2 ("cat " ^ file); *)
1063 let cprogram = cprogram_of_file file in
1064 let xs = build_info_program cprogram c
.env_typing_before
in
1066 (* TODO: assert env has not changed,
1067 * if yes then must also reparse what follows even if not modified.
1068 * Do that only if contain_typedmetavar of course, so good opti.
1070 (* Common.list_init xs *) (* get rid of the FinalDef *)
1076 let rebuild_info_c_and_headers ccs isexp
=
1077 ccs
+> List.iter
(fun c_or_h
->
1078 if c_or_h
.asts
+> List.exists
(fun c
-> !(c
.was_modified
))
1079 then c_or_h
.was_modified_once
:= true;
1081 ccs
+> List.map
(fun c_or_h
->
1084 rebuild_info_program c_or_h
.asts c_or_h
.full_fname isexp
}
1087 let rec prepare_h seen env hpath choose_includes
: file_info list
=
1088 if not
(Common.lfile_exists hpath
)
1091 pr2_once
("TYPE: header " ^ hpath ^
" not found");
1096 let h_cs = cprogram_of_file_cached hpath
in
1097 let local_includes =
1098 if choose_includes
=*= Flag_cocci.I_REALLY_ALL_INCLUDES
1101 (function x
-> not
(List.mem x
!seen))
1102 (includes_to_parse
[(hpath
,h_cs)] choose_includes
)
1104 seen := local_includes @ !seen;
1107 (List.map
(function x
-> prepare_h seen env x choose_includes
)
1109 let info_h_cs = build_info_program h_cs !env
in
1113 else last_env_toplevel_c_info info_h_cs;
1116 fname
= Common.basename hpath
;
1119 was_modified_once
= ref false;
1125 let prepare_c files choose_includes
: file_info list
=
1126 let cprograms = List.map
cprogram_of_file_cached files
in
1127 let includes = includes_to_parse
(zip files
cprograms) choose_includes
in
1128 let seen = ref includes in
1130 (* todo?: may not be good to first have all the headers and then all the c *)
1131 let env = ref !TAC.initial_env
in
1135 List.map
(function hpath
-> prepare_h seen env hpath choose_includes
) +>
1139 (zip files
cprograms) +>
1141 (function (file, cprogram) ->
1142 (* todo?: don't update env ? *)
1143 let cs = build_info_program cprogram !env in
1144 (* we do that only for the c, not for the h *)
1145 ignore
(update_include_rel_pos (cs +> List.map
(fun x
-> x
.ast_c
)));
1147 fname
= Common.basename
file;
1150 was_modified_once
= ref false;
1157 (*****************************************************************************)
1158 (* Processing the ctls and toplevel C elements *)
1159 (*****************************************************************************)
1161 (* The main algorithm =~
1162 * The algorithm is roughly:
1163 * for_all ctl rules in SP
1164 * for_all minirule in rule (no more)
1165 * for_all binding (computed during previous phase)
1166 * for_all C elements
1167 * match control flow of function vs minirule
1168 * with the binding and update the set of possible
1169 * bindings, and returned the possibly modified function.
1170 * pretty print modified C elements and reparse it.
1173 * On ne prends que les newbinding ou returned_any_state est vrai.
1174 * Si ca ne donne rien, on prends ce qu'il y avait au depart.
1175 * Mais au nouveau depart de quoi ?
1176 * - si ca donne rien apres avoir traité toutes les fonctions avec ce binding ?
1177 * - ou alors si ca donne rien, apres avoir traité toutes les fonctions
1178 * avec tous les bindings du round d'avant ?
1180 * Julia pense qu'il faut prendre la premiere solution.
1181 * Example: on a deux environnements candidats, E1 et E2 apres avoir traité
1182 * la regle ctl 1. On arrive sur la regle ctl 2.
1183 * E1 ne donne rien pour la regle 2, on garde quand meme E1 pour la regle 3.
1184 * E2 donne un match a un endroit et rend E2' alors on utilise ca pour
1187 * I have not to look at used_after_list to decide to restart from
1188 * scratch. I just need to look if the binding list is empty.
1189 * Indeed, let's suppose that a SP have 3 regions/rules. If we
1190 * don't find a match for the first region, then if this first
1191 * region does not bind metavariable used after, that is if
1192 * used_after_list is empty, then mysat(), even if does not find a
1193 * match, will return a Left, with an empty transformation_info,
1194 * and so current_binding will grow. On the contrary if the first
1195 * region must bind some metavariables used after, and that we
1196 * dont find any such region, then mysat() will returns lots of
1197 * Right, and current_binding will not grow, and so we will have
1198 * an empty list of binding, and we will catch such a case.
1200 * opti: julia says that because the binding is
1201 * determined by the used_after_list, the items in the list
1202 * are kind of sorted, so could optimise the insert_set operations.
1206 (* r(ule), c(element in C code), e(nvironment) *)
1209 let rec loop k
= function
1213 then Some
(x
, function n
-> k
(n
:: xs))
1214 else loop (function vs
-> k
(x
:: vs
)) xs in
1215 loop (function x
-> x
) l
1217 let merge_env new_e old_e
=
1220 (function (ext
,old_e
) ->
1221 function (e
,rules
) as elem
->
1222 match findk (function (e1
,_) -> e
=*= e1
) old_e
with
1223 None
-> (elem
:: ext
,old_e
)
1224 | Some
((_,old_rules
),k
) ->
1225 (ext
,k
(e
,Common.union_set rules old_rules
)))
1227 old_e
@ (List.rev ext
)
1229 let contains_binding e
(_,(r,m
),_) =
1231 let _ = List.find
(function ((re
, rm
), _) -> r =*= re
&& m
=$
= rm
) e
in
1233 with Not_found
-> false
1235 let python_application mv ve script_vars
r =
1239 ((Some x
,None
),y
,z
) -> (x
,y
,z
)
1242 (Printf.sprintf
"unexpected ast metavar in rule %s"
1243 r.scr_rule_info
.rulename
))
1246 Pycocci.build_classes
(List.map
(function (x
,y
) -> x
) ve
);
1247 Pycocci.construct_variables
mv ve
;
1248 Pycocci.construct_script_variables script_vars
;
1249 let _ = Pycocci.pyrun_simplestring
(local_python_code ^
r.script_code
) in
1250 if !Pycocci.inc_match
1251 then Some
(Pycocci.retrieve_script_variables script_vars
)
1253 with Pycocci.Pycocciexception
->
1254 (pr2
("Failure in " ^
r.scr_rule_info
.rulename
);
1255 raise
Pycocci.Pycocciexception
)
1257 let ocaml_application mv ve script_vars
r =
1260 Run_ocamlcocci.run
mv ve script_vars
1261 r.scr_rule_info
.rulename
r.script_code
in
1262 if !Coccilib.inc_match
1263 then Some
script_vals
1265 with e
-> (pr2
("Failure in " ^
r.scr_rule_info
.rulename
); raise e
)
1267 (* returns Left in case of dependency failure, Right otherwise *)
1268 let apply_script_rule r cache newes e rules_that_have_matched
1269 rules_that_have_ever_matched script_application
=
1270 Common.profile_code
r.language
(fun () ->
1271 show_or_not_scr_rule_name r.scr_rule_info
.ruleid
;
1272 if not
(interpret_dependencies rules_that_have_matched
1273 !rules_that_have_ever_matched
r.scr_rule_info
.dependencies
)
1276 print_dependencies "dependencies for script not satisfied:"
1277 rules_that_have_matched
1278 !rules_that_have_ever_matched
r.scr_rule_info
.dependencies
;
1279 show_or_not_binding "in environment" e
;
1280 (cache
, (e
, rules_that_have_matched
)::newes
)
1284 let (_, mv, script_vars
, _) = r.scr_ast_rule
in
1286 (List.map
(function (n
,v
) -> (("virtual",n
),Ast_c.MetaIdVal
(v
,[])))
1287 !Flag.defined_virtual_env
) @ e
in
1288 let not_bound x
= not
(contains_binding ve x
) in
1289 (match List.filter
not_bound mv with
1291 let relevant_bindings =
1293 (function ((re
,rm
),_) ->
1294 List.exists
(function (_,(r,m
),_) -> r =*= re
&& m
=$
= rm
) mv)
1297 match List.assoc
relevant_bindings cache
with
1298 None
-> (cache
,newes
)
1299 | Some
script_vals ->
1301 "dependencies for script satisfied, but cached:"
1302 rules_that_have_matched
1303 !rules_that_have_ever_matched
1304 r.scr_rule_info
.dependencies
;
1305 show_or_not_binding "in" e
;
1306 (* env might be bigger than what was cached against, so have to
1307 merge with newes anyway *)
1308 let new_e = (List.combine script_vars
script_vals) @ e
in
1312 (fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1313 (cache
,merge_env [(new_e, rules_that_have_matched
)] newes
)
1316 print_dependencies "dependencies for script satisfied:"
1317 rules_that_have_matched
1318 !rules_that_have_ever_matched
1319 r.scr_rule_info
.dependencies
;
1320 show_or_not_binding "in" e
;
1321 match script_application
mv ve script_vars
r with
1323 (* failure means we should drop e, no new bindings *)
1324 (((relevant_bindings,None
) :: cache
), newes
)
1325 | Some
script_vals ->
1327 List.map
(function x
-> Ast_c.MetaIdVal
(x
,[]))
1330 (List.combine script_vars
script_vals) @ e
in
1334 (fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1335 r.scr_rule_info
.was_matched
:= true;
1336 (((relevant_bindings,Some
script_vals) :: cache
),
1339 r.scr_rule_info
.rulename
:: rules_that_have_matched
)]
1343 (if !Flag_cocci.show_dependencies
1345 let m2c (_,(r,x
),_) = r^
"."^x
in
1346 pr2
(Printf.sprintf
"script not applied: %s not bound"
1347 (String.concat
", " (List.map
m2c unbound
))));
1351 (fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1352 (cache
, merge_env [(e, rules_that_have_matched
)] newes
))
1355 let rec apply_cocci_rule r rules_that_have_ever_matched es
1356 (ccs
:file_info list
ref) =
1357 Common.profile_code
r.rule_info
.rulename
(fun () ->
1358 show_or_not_rule_name r.ast_rule
r.rule_info
.ruleid
;
1359 show_or_not_ctl_text r.ctl
r.ast_rule
r.rule_info
.ruleid
;
1361 let reorganized_env =
1362 reassociate_positions
r.free_vars
r.negated_pos_vars
!es
in
1364 (* looping over the environments *)
1365 let (_,newes
(* envs for next round/rule *)) =
1367 (function (cache
,newes
) ->
1368 function ((e,rules_that_have_matched
),relevant_bindings) ->
1369 if not
(interpret_dependencies rules_that_have_matched
1370 !rules_that_have_ever_matched
1371 r.rule_info
.dependencies
)
1375 ("dependencies for rule "^
r.rule_info
.rulename^
1377 rules_that_have_matched
1378 !rules_that_have_ever_matched
r.rule_info
.dependencies
;
1379 show_or_not_binding "in environment" e;
1384 (fun (s,v
) -> List.mem
s r.rule_info
.used_after
),
1385 rules_that_have_matched
)]
1390 try List.assoc
relevant_bindings cache
1394 ("dependencies for rule "^
r.rule_info
.rulename^
1396 rules_that_have_matched
1397 !rules_that_have_ever_matched
1398 r.rule_info
.dependencies
;
1399 show_or_not_binding "in" e;
1400 show_or_not_binding "relevant in" relevant_bindings;
1402 (* applying the rule *)
1403 (match r.ruletype
with
1405 (* looping over the functions and toplevel elements in
1408 (concat_headers_and_c !ccs
+>
1409 List.fold_left
(fun children_e
(c
,f) ->
1412 (* does also some side effects on c and r *)
1414 process_a_ctl_a_env_a_toplevel
r
1415 relevant_bindings c
f in
1416 match processed with
1417 | None
-> children_e
1418 | Some newbindings
->
1421 (fun children_e newbinding
->
1422 if List.mem newbinding children_e
1424 else newbinding
:: children_e
)
1428 | Ast_cocci.Generated
->
1429 process_a_generated_a_env_a_toplevel
r
1430 relevant_bindings !ccs
;
1433 let old_bindings_to_keep =
1437 (fun (s,v
) -> List.mem
s r.rule_info
.used_after
)) in
1439 if null
new_bindings
1442 (*use the old bindings, specialized to the used_after_list*)
1443 if !Flag_ctl.partial_match
1446 "Empty list of bindings, I will restart from old env\n";
1447 [(old_bindings_to_keep,rules_that_have_matched
)]
1450 (* combine the new bindings with the old ones, and
1451 specialize to the used_after_list *)
1452 let old_variables = List.map fst
old_bindings_to_keep in
1453 (* have to explicitly discard the inherited variables
1454 because we want the inherited value of the positions
1455 variables not the extended one created by
1456 reassociate_positions. want to reassociate freshly
1457 according to the free variables of each rule. *)
1458 let new_bindings_to_add =
1464 (* see comment before combine_pos *)
1465 (s,Ast_c.MetaPosValList
[]) -> false
1467 List.mem
s r.rule_info
.used_after
&&
1468 not
(List.mem
s old_variables)))) in
1470 (function new_binding_to_add
->
1473 old_bindings_to_keep new_binding_to_add
),
1474 r.rule_info
.rulename
::rules_that_have_matched
))
1475 new_bindings_to_add in
1476 ((relevant_bindings,new_bindings)::cache
,
1477 merge_env new_e newes
))
1478 ([],[]) reorganized_env in (* end iter es *)
1479 if !(r.rule_info
.was_matched
)
1480 then Common.push2
r.rule_info
.rulename rules_that_have_ever_matched
;
1484 (* apply the tagged modifs and reparse *)
1485 if not
!Flag.sgrep_mode2
1486 then ccs
:= rebuild_info_c_and_headers !ccs
r.isexp
)
1488 and reassociate_positions free_vars negated_pos_vars envs
=
1489 (* issues: isolate the bindings that are relevant to a given rule.
1490 separate out the position variables
1491 associate all of the position variables for a given set of relevant
1492 normal variable bindings with each set of relevant normal variable
1493 bindings. Goal: if eg if@p (E) matches in two places, then both inherited
1494 occurrences of E should see both bindings of p, not just its own.
1495 Otherwise, a position constraint for something that matches in two
1496 places will never be useful, because the position can always be
1497 different from the other one. *)
1501 List.filter
(function (x
,_) -> List.mem x free_vars
) e)
1503 let splitted_relevant =
1504 (* separate the relevant variables into the non-position ones and the
1509 (function (non_pos
,pos
) ->
1510 function (v
,_) as x
->
1511 if List.mem v negated_pos_vars
1512 then (non_pos
,x
::pos
)
1513 else (x
::non_pos
,pos
))
1516 let splitted_relevant =
1518 (function (non_pos
,pos
) ->
1519 (List.sort compare non_pos
,List.sort compare pos
))
1520 splitted_relevant in
1523 (function non_pos
->
1525 if List.mem np non_pos
then non_pos
else np
::non_pos
)
1526 [] splitted_relevant in
1527 let extended_relevant =
1528 (* extend the position variables with the values found at other identical
1529 variable bindings *)
1531 (function non_pos
->
1534 (function (other_non_pos
,other_pos
) ->
1535 (* do we want equal? or just somehow compatible? eg non_pos
1536 binds only E, but other_non_pos binds both E and E1 *)
1537 non_pos
=*= other_non_pos
)
1538 splitted_relevant in
1542 (combine_pos negated_pos_vars
1543 (List.map
(function (_,x
) -> x
) others)))))
1546 (List.map
(function (non_pos
,_) -> List.assoc non_pos
extended_relevant)
1549 (* If the negated posvar is not bound at all, this function will
1550 nevertheless bind it to []. If we get rid of these bindings, then the
1551 matching of the term the position variable with the constraints will fail
1552 because some variables are unbound. So we let the binding be [] and then
1553 we will have to clean these up afterwards. This should be the only way
1554 that a position variable can have an empty binding. *)
1555 and combine_pos negated_pos_vars
others =
1561 (function positions ->
1562 function other_list
->
1564 match List.assoc posvar other_list
with
1565 Ast_c.MetaPosValList l1
->
1566 Common.union_set l1
positions
1567 | _ -> failwith
"bad value for a position variable"
1568 with Not_found
-> positions)
1570 (posvar
,Ast_c.MetaPosValList
positions))
1573 and process_a_generated_a_env_a_toplevel2
r env = function
1578 (rule
,_) when rule
=$
= r.rule_info
.rulename
-> false
1579 | (_,"ARGS") -> false
1582 let env_domain = List.map
(function (nm
,vl
) -> nm
) env in
1586 let (rl
,_) = Ast_cocci.get_meta_name md
in rl
=$
= r.rule_info
.rulename
)
1588 if Common.include_set
free_vars env_domain
1589 then Unparse_hrule.pp_rule
metavars r.ast_rule
env cfile
.full_fname
1590 | _ -> failwith
"multiple files not supported"
1592 and process_a_generated_a_env_a_toplevel rule
env ccs
=
1593 Common.profile_code
"process_a_ctl_a_env_a_toplevel"
1594 (fun () -> process_a_generated_a_env_a_toplevel2 rule
env ccs
)
1596 (* does side effects on C ast and on Cocci info rule *)
1597 and process_a_ctl_a_env_a_toplevel2
r e c
f =
1598 indent_do
(fun () ->
1599 show_or_not_celem "trying" c
.ast_c
;
1600 Flag.currentfile
:= Some
(f ^
":" ^
get_celem c
.ast_c
);
1601 let (trans_info, returned_any_states
, inherited_bindings
, newbindings
) =
1602 Common.save_excursion
Flag_ctl.loop_in_src_code
(fun () ->
1603 Flag_ctl.loop_in_src_code
:= !Flag_ctl.loop_in_src_code
||c
.contain_loop;
1605 (***************************************)
1606 (* !Main point! The call to the engine *)
1607 (***************************************)
1608 let model_ctl = CCI.model_for_ctl
r.dropped_isos
(Common.some c
.flow) e
1609 in CCI.mysat
model_ctl r.ctl
(r.rule_info
.used_after
, e)
1612 if not returned_any_states
1615 show_or_not_celem "found match in" c
.ast_c
;
1616 show_or_not_trans_info trans_info;
1617 List.iter
(show_or_not_binding "out") newbindings
;
1619 r.rule_info
.was_matched
:= true;
1621 if not
(null
trans_info) &&
1622 not
(!Flag.sgrep_mode2
&& not
!Flag_cocci.show_diff
)
1624 c
.was_modified
:= true;
1626 (* les "more than one var in a decl" et "already tagged token"
1627 * font crasher coccinelle. Si on a 5 fichiers, donc on a 5
1628 * failed. Le try limite le scope des crashes pendant la
1629 * trasformation au fichier concerne. *)
1631 (* modify ast via side effect *)
1632 ignore
(Transformation_c.transform
r.rule_info
.rulename
r.dropped_isos
1633 inherited_bindings
trans_info (Common.some c
.flow));
1634 with Timeout
-> raise Timeout
| UnixExit i
-> raise
(UnixExit i
)
1637 Some
(List.map
(function x
-> x
@inherited_bindings
) newbindings
)
1641 and process_a_ctl_a_env_a_toplevel a b c
f=
1642 Common.profile_code
"process_a_ctl_a_env_a_toplevel"
1643 (fun () -> process_a_ctl_a_env_a_toplevel2 a b c
f)
1646 let rec bigloop2 rs
(ccs
: file_info list
) =
1647 let init_es = [(Ast_c.emptyMetavarsBinding
,[])] in
1648 let es = ref init_es in
1649 let ccs = ref ccs in
1650 let rules_that_have_ever_matched = ref [] in
1652 (* looping over the rules *)
1653 rs
+> List.iter
(fun r ->
1655 InitialScriptRuleCocciInfo
r | FinalScriptRuleCocciInfo
r -> ()
1656 | ScriptRuleCocciInfo
r ->
1657 if !Flag_cocci.show_ctl_text
then begin
1658 Common.pr_xxxxxxxxxxxxxxxxx
();
1659 pr
("script: " ^
r.language
);
1660 Common.pr_xxxxxxxxxxxxxxxxx
();
1662 adjust_pp_with_indent
(fun () ->
1663 Format.force_newline
();
1664 let (l,mv,script_vars
,code
) = r.scr_ast_rule
in
1665 let nm = r.scr_rule_info
.rulename
in
1666 let deps = r.scr_rule_info
.dependencies
in
1667 Pretty_print_cocci.unparse
1668 (Ast_cocci.ScriptRule
(nm,l,deps,mv,script_vars
,code
)));
1671 if !Flag.show_misc
then print_endline
"RESULT =";
1675 (function (cache
, newes
) ->
1676 function (e, rules_that_have_matched
) ->
1677 match r.language
with
1679 apply_script_rule r cache newes
e rules_that_have_matched
1680 rules_that_have_ever_matched python_application
1682 apply_script_rule r cache newes
e rules_that_have_matched
1683 rules_that_have_ever_matched ocaml_application
1685 concat_headers_and_c !ccs +> List.iter
(fun (c
,_) ->
1688 Printf.printf
"Flow: %s\r\nFlow!\r\n%!" c
.fullstring
);
1691 Printf.printf
"Unknown language: %s\n" r.language
;
1695 (if !(r.scr_rule_info
.was_matched
)
1697 Common.push2
r.scr_rule_info
.rulename
rules_that_have_ever_matched);
1699 es := newes
(*(if newes = [] then init_es else newes)*);
1700 | CocciRuleCocciInfo
r ->
1701 apply_cocci_rule r rules_that_have_ever_matched
1704 if !Flag.sgrep_mode2
1706 (* sgrep can lead to code that is not parsable, but we must
1707 * still call rebuild_info_c_and_headers to pretty print the
1708 * action (MINUS), so that later the diff will show what was
1709 * matched by sgrep. But we don't want the parsing error message
1710 * hence the following flag setting. So this code propably
1711 * will generate a NotParsedCorrectly for the matched parts
1712 * and the very final pretty print and diff will work
1714 Flag_parsing_c.verbose_parsing
:= false;
1715 ccs := rebuild_info_c_and_headers !ccs false
1717 !ccs (* return final C asts *)
1720 Common.profile_code
"bigloop" (fun () -> bigloop2 a b
)
1722 type init_final
= Initial
| Final
1724 let initial_final_bigloop2 ty rebuild
r =
1725 if !Flag_cocci.show_ctl_text
then
1727 Common.pr_xxxxxxxxxxxxxxxxx
();
1728 pr
((match ty
with Initial
-> "initial" | Final
-> "final") ^
": " ^
1730 Common.pr_xxxxxxxxxxxxxxxxx
();
1732 adjust_pp_with_indent
(fun () ->
1733 Format.force_newline
();
1734 Pretty_print_cocci.unparse
(rebuild
r.scr_ast_rule
r.scr_rule_info
.dependencies
));
1737 match r.language
with
1739 (* include_match makes no sense in an initial or final rule, although
1740 we have no way to prevent it *)
1741 let _ = apply_script_rule r [] [] [] [] (ref []) python_application in
1743 | "ocaml" when ty
= Initial
-> () (* nothing to do *)
1745 (* include_match makes no sense in an initial or final rule, although
1746 we have no way to prevent it *)
1747 let _ = apply_script_rule r [] [] [] [] (ref []) ocaml_application in
1750 failwith
("Unknown language for initial/final script: "^
1753 let initial_final_bigloop a b c
=
1754 Common.profile_code
"initial_final_bigloop"
1755 (fun () -> initial_final_bigloop2 a b c
)
1757 (*****************************************************************************)
1758 (* The main functions *)
1759 (*****************************************************************************)
1761 let pre_engine2 (coccifile
, isofile
) =
1762 show_or_not_cocci coccifile isofile
;
1763 Pycocci.set_coccifile coccifile
;
1766 if not
(Common.lfile_exists
isofile)
1768 pr2
("warning: Can't find default iso file: " ^
isofile);
1771 else Some
isofile in
1773 (* useful opti when use -dir *)
1774 let (metavars,astcocci
,
1775 free_var_lists
,negated_pos_lists
,used_after_lists
,
1776 positions_lists
,(toks
,_,_)) =
1777 sp_of_file coccifile
isofile in
1778 let ctls = ctls_of_ast astcocci used_after_lists positions_lists
in
1780 g_contain_typedmetavar := sp_contain_typed_metavar astcocci
;
1782 check_macro_in_sp_and_adjust toks
;
1784 show_or_not_ctl_tex astcocci
ctls;
1787 prepare_cocci ctls free_var_lists negated_pos_lists
1788 used_after_lists positions_lists
metavars astcocci
in
1790 let used_languages =
1792 (function languages
->
1794 ScriptRuleCocciInfo
(r) ->
1795 if List.mem
r.language languages
then
1798 r.language
::languages
1803 let rlang = r.language
in
1804 let rname = r.scr_rule_info
.rulename
in
1806 let _ = List.assoc
(rlang,rname) !Iteration.initialization_stack
in
1810 Iteration.initialization_stack
:=
1811 ((rlang,rname),!Flag.defined_virtual_rules
) ::
1812 !Iteration.initialization_stack
;
1813 initial_final_bigloop Initial
1814 (fun (x
,_,_,y
) -> fun deps ->
1815 Ast_cocci.InitialScriptRule
(rname,x
,deps,y
))
1819 let initialized_languages =
1821 (function languages
->
1823 InitialScriptRuleCocciInfo
(r) ->
1824 let rlang = r.language
in
1825 (if List.mem
rlang languages
1826 then failwith
("double initializer found for "^
rlang));
1827 if interpret_dependencies [] [] r.scr_rule_info
.dependencies
1828 then begin runrule r; rlang::languages
end
1833 let uninitialized_languages =
1835 (fun used
-> not
(List.mem used
initialized_languages))
1842 dependencies
= Ast_cocci.NoDep
;
1845 was_matched
= ref false;} in
1846 runrule (make_init lgg
"" rule_info))
1847 uninitialized_languages;
1852 Common.profile_code
"pre_engine" (fun () -> pre_engine2 a
)
1854 let full_engine2 (cocci_infos,toks
) cfiles =
1856 show_or_not_cfiles cfiles;
1858 (* optimisation allowing to launch coccinelle on all the drivers *)
1859 if !Flag_cocci.worth_trying_opt
&& not
(worth_trying cfiles toks
)
1865 pr2
("No matches found for " ^
(Common.join
" " toks
)
1866 ^
"\nSkipping:" ^
(Common.join
" " cfiles)));
1867 cfiles +> List.map
(fun s -> s, None
)
1872 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1873 if !Flag.show_misc
then pr
"let's go";
1874 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1876 let choose_includes =
1877 match !Flag_cocci.include_options
with
1878 Flag_cocci.I_UNSPECIFIED
->
1879 if !g_contain_typedmetavar
1880 then Flag_cocci.I_NORMAL_INCLUDES
1881 else Flag_cocci.I_NO_INCLUDES
1883 let c_infos = prepare_c cfiles choose_includes in
1885 (* ! the big loop ! *)
1886 let c_infos'
= bigloop cocci_infos c_infos in
1888 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1889 if !Flag.show_misc
then pr
"Finished";
1890 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1891 if !Flag_ctl.graphical_trace
then gen_pdf_graph ();
1893 c_infos'
+> List.map
(fun c_or_h
->
1894 if !(c_or_h
.was_modified_once
)
1898 Common.new_temp_file
"cocci-output" ("-" ^ c_or_h
.fname
) in
1900 if c_or_h
.fkind
=*= Header
1901 then pr2
("a header file was modified: " ^ c_or_h
.fname
);
1903 (* and now unparse everything *)
1904 cfile_of_program (for_unparser c_or_h
.asts
) outfile;
1906 show_or_not_diff c_or_h
.fpath
outfile;
1909 if !Flag.sgrep_mode2
then None
else Some
outfile)
1911 else (c_or_h
.fpath
, None
))
1914 let full_engine a b
=
1915 Common.profile_code
"full_engine"
1916 (fun () -> let res = full_engine2 a b
in (*Gc.print_stat stderr; *)res)
1918 let post_engine2 (cocci_infos,_) =
1920 (function ((language
,_),virt_rules
) ->
1921 Flag.defined_virtual_rules
:= virt_rules
;
1924 (function languages
->
1926 FinalScriptRuleCocciInfo
(r) ->
1927 (if r.language
= language
&& List.mem
r.language languages
1928 then failwith
("double finalizer found for "^
r.language
));
1929 initial_final_bigloop Final
1930 (fun (x
,_,_,y
) -> fun deps ->
1931 Ast_cocci.FinalScriptRule
(r.scr_rule_info
.rulename
,
1934 r.language
::languages
1938 !Iteration.initialization_stack
1941 Common.profile_code
"post_engine" (fun () -> post_engine2 a
)
1943 (*****************************************************************************)
1944 (* check duplicate from result of full_engine *)
1945 (*****************************************************************************)
1947 let check_duplicate_modif2 xs =
1948 (* opti: let groups = Common.groupBy (fun (a,resa) (b,resb) -> a =$= b) xs *)
1949 if !Flag_cocci.verbose_cocci
1950 then pr2
("Check duplication for " ^ i_to_s
(List.length
xs) ^
" files");
1952 let groups = Common.group_assoc_bykey_eff
xs in
1953 groups +> Common.map_filter
(fun (file, xs) ->
1955 | [] -> raise Impossible
1956 | [res] -> Some
(file, res)
1960 if not
(List.for_all
(fun res2
-> res2
=*= None
) xs)
1962 pr2
("different modification result for " ^
file);
1965 else Some
(file, None
)
1967 if not
(List.for_all
(fun res2
->
1971 let diff = Common.cmd_to_list
("diff -u -b -B "^
res^
" "^res2
)
1975 pr2
("different modification result for " ^
file);
1978 else Some
(file, Some
res)
1980 let check_duplicate_modif a
=
1981 Common.profile_code
"check_duplicate" (fun () -> check_duplicate_modif2 a
)