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 _hctl = Hashtbl.create
101
67 (* --------------------------------------------------------------------- *)
69 (* --------------------------------------------------------------------- *)
70 let sp_of_file2 file iso
=
71 Common.memoized
_hparse (file
, iso
) (fun () ->
72 let (_
,xs
,_
,_
,_
,_
,_
) as res
= Parse_cocci.process file iso
false in
73 (match Prepare_ocamlcocci.prepare file xs
with
75 | Some ocaml_script_file
->
77 Prepare_ocamlcocci.load_file ocaml_script_file
;
78 if not
!Common.save_tmp_files
79 then Prepare_ocamlcocci.clean_file ocaml_script_file
);
81 let sp_of_file file iso
=
82 Common.profile_code
"parse cocci" (fun () -> sp_of_file2 file iso
)
85 (* --------------------------------------------------------------------- *)
87 (* --------------------------------------------------------------------- *)
89 Ograph_extended.print_ograph_mutable flow
"/tmp/test.dot" true
92 let ast_to_flow_with_error_messages2 x
=
94 try Ast_to_flow.ast_to_control_flow x
95 with Ast_to_flow.Error x
->
96 Ast_to_flow.report_error x
;
99 flowopt +> do_option
(fun flow
->
100 (* This time even if there is a deadcode, we still have a
101 * flow graph, so I can try the transformation and hope the
102 * deadcode will not bother us.
104 try Ast_to_flow.deadcode_detection flow
105 with Ast_to_flow.Error
(Ast_to_flow.DeadCode x
) ->
106 Ast_to_flow.report_error
(Ast_to_flow.DeadCode x
);
109 let ast_to_flow_with_error_messages a
=
110 Common.profile_code
"flow" (fun () -> ast_to_flow_with_error_messages2 a
)
113 (* --------------------------------------------------------------------- *)
115 (* --------------------------------------------------------------------- *)
117 let ctls_of_ast2 ast
(ua
,fua
,fuas
) pos
=
119 (function ast
-> function (ua
,(fua
,(fuas
,pos
))) ->
123 else Asttoctl2.asttoctl ast
(ua
,fua
,fuas
) pos
)
124 (Asttomember.asttomember ast ua
))
125 ast
(List.combine ua
(List.combine fua
(List.combine fuas pos
)))
127 let ctls_of_ast ast ua
=
128 Common.profile_code
"asttoctl2" (fun () -> ctls_of_ast2 ast ua
)
130 (*****************************************************************************)
131 (* Some debugging functions *)
132 (*****************************************************************************)
136 let show_or_not_cfile2 cfile
=
137 if !Flag_cocci.show_c
then begin
138 Common.pr2_xxxxxxxxxxxxxxxxx
();
139 pr2
("processing C file: " ^ cfile
);
140 Common.pr2_xxxxxxxxxxxxxxxxx
();
141 Common.command2
("cat " ^ cfile
);
143 let show_or_not_cfile a
=
144 Common.profile_code
"show_xxx" (fun () -> show_or_not_cfile2 a
)
146 let show_or_not_cfiles cfiles
= List.iter
show_or_not_cfile cfiles
149 let show_or_not_cocci2 coccifile isofile
=
150 if !Flag_cocci.show_cocci
then begin
151 Common.pr2_xxxxxxxxxxxxxxxxx
();
152 pr2
("processing semantic patch file: " ^ coccifile
);
153 isofile
+> (fun s
-> pr2
("with isos from: " ^ s
));
154 Common.pr2_xxxxxxxxxxxxxxxxx
();
155 Common.command2
("cat " ^ coccifile
);
158 let show_or_not_cocci a b
=
159 Common.profile_code
"show_xxx" (fun () -> show_or_not_cocci2 a b
)
161 (* ---------------------------------------------------------------------- *)
164 let fix_sgrep_diffs l
=
166 List.filter
(function s
-> (s
=~
"^\\+\\+\\+") || not
(s
=~
"^\\+")) l in
167 let l = List.rev
l in
168 (* adjust second number for + code *)
169 let rec loop1 n
= function
172 if s
=~
"^-" && not
(s
=~
"^---")
173 then s
:: loop1 (n
+1) ss
176 (match Str.split
(Str.regexp
" ") s
with
179 match Str.split
(Str.regexp
",") pl
with
182 | _
-> failwith
"bad + line information" in
183 let n2 = int_of_string
n2 in
184 (Printf.sprintf
"%s %s %s,%d %s" bef min n1
(n2-n
)
185 (String.concat
" " aft
))
187 | _
-> failwith
"bad @@ information")
188 else s
:: loop1 n ss
in
189 let rec loop2 n
= function
196 (match Str.split
(Str.regexp
" ") s
with
199 match (Str.split
(Str.regexp
",") min
,
200 Str.split
(Str.regexp
",") pl
) with
201 ([_
;m2
],[n1
;n2]) -> (m2
,n1
,n2)
202 | ([_
],[n1
;n2]) -> ("1",n1
,n2)
203 | ([_
;m2
],[n1
]) -> (m2
,n1
,"1")
204 | ([_
],[n1
]) -> ("1",n1
,"1")
205 | _
-> failwith
"bad -/+ line information" in
207 int_of_string
(String.sub
n1 1 ((String.length
n1)-1)) in
208 let m2 = int_of_string
m2 in
209 let n2 = int_of_string
n2 in
210 (Printf.sprintf
"%s %s +%d,%d %s" bef min
(n1-n
) n2
211 (String.concat
" " aft
))
212 :: loop2 (n
+(m2-n2)) ss
213 | _
-> failwith
"bad @@ information")
214 else s
:: loop2 n ss
in
215 loop2 0 (List.rev
(loop1 0 l))
217 let normalize_path file
=
219 if String.get file
0 = '
/'
then file
else (Sys.getcwd
()) ^
"/" ^ file
in
220 let elements = Str.split_delim
(Str.regexp
"/") fullpath in
221 let rec loop prev
= function
222 [] -> String.concat
"/" (List.rev prev
)
223 | "." :: rest
-> loop prev rest
226 x
::xs
-> loop xs rest
227 | _
-> failwith
"bad path")
228 | x
::rest
-> loop (x
::prev
) rest
in
231 let show_or_not_diff2 cfile outfile
=
232 if !Flag_cocci.show_diff
then begin
233 match Common.fst
(Compare_c.compare_to_original cfile outfile
) with
234 Compare_c.Correct
-> () (* diff only in spacing, etc *)
236 (* may need --strip-trailing-cr under windows *)
240 match !Flag_parsing_c.diff_lines
with
241 | None
-> "diff -u -p " ^ cfile ^
" " ^ outfile
242 | Some n
-> "diff -U "^n^
" -p "^cfile^
" "^outfile
in
244 let res = Common.cmd_to_list
line in
245 match (!Flag.patch
,res) with
246 (* create something that looks like the output of patch *)
247 (Some prefix
,minus_file
::plus_file
::rest
) ->
249 let lp = String.length
prefix in
250 if String.get
prefix (lp-1) = '
/'
251 then String.sub
prefix 0 (lp-1)
253 let drop_prefix file
=
254 let file = normalize_path file in
255 if Str.string_match
(Str.regexp
prefix) file 0
257 let lp = String.length
prefix in
258 let lf = String.length
file in
260 then String.sub
file lp (lf - lp)
263 (Printf.sprintf
"prefix %s doesn't match file %s"
267 (Printf.sprintf
"prefix %s doesn't match file %s"
270 match List.rev
(Str.split
(Str.regexp
" ") line) with
271 new_file
::old_file
::cmdrev
->
272 let old_base_file = drop_prefix old_file
in
277 (("/tmp/nothing"^
old_base_file)
278 :: old_file
:: cmdrev
))
282 (("b"^
old_base_file)::("a"^
old_base_file)::cmdrev
))
283 | _
-> failwith
"bad command" in
284 let (minus_line
,plus_line
) =
285 match (Str.split
(Str.regexp
"[ \t]") minus_file
,
286 Str.split
(Str.regexp
"[ \t]") plus_file
) with
287 ("---"::old_file
::old_rest
,"+++"::new_file
::new_rest
) ->
288 let old_base_file = drop_prefix old_file
in
290 then (minus_file
,"+++ /tmp/nothing"^
old_base_file)
293 ("---"::("a"^
old_base_file)::old_rest
),
295 ("+++"::("b"^
old_base_file)::new_rest
))
298 (Printf.sprintf
"bad diff header lines: %s %s"
299 (String.concat
":" l1
) (String.concat
":" l2
)) in
300 diff_line::minus_line
::plus_line
::rest
302 let xs = if !Flag.sgrep_mode2
then fix_sgrep_diffs xs else xs in
305 let show_or_not_diff a b
=
306 Common.profile_code
"show_xxx" (fun () -> show_or_not_diff2 a b
)
309 (* the derived input *)
311 let show_or_not_ctl_tex2 astcocci ctls
=
312 if !Flag_cocci.show_ctl_tex
then begin
313 Ctltotex.totex
("/tmp/__cocci_ctl.tex") astcocci ctls
;
314 Common.command2
("cd /tmp; latex __cocci_ctl.tex; " ^
315 "dvips __cocci_ctl.dvi -o __cocci_ctl.ps;" ^
316 "gv __cocci_ctl.ps &");
318 let show_or_not_ctl_tex a b
=
319 Common.profile_code
"show_xxx" (fun () -> show_or_not_ctl_tex2 a b
)
322 let show_or_not_rule_name ast rulenb
=
323 if !Flag_cocci.show_ctl_text
or !Flag.show_trying
or
324 !Flag.show_transinfo
or !Flag_cocci.show_binding_in_out
329 Ast_cocci.CocciRule
(nm
, (deps
, drops
, exists
), x
, _
, _
) -> nm
330 | _
-> i_to_s rulenb
in
331 Common.pr_xxxxxxxxxxxxxxxxx
();
333 Common.pr_xxxxxxxxxxxxxxxxx
()
336 let show_or_not_scr_rule_name rulenb
=
337 if !Flag_cocci.show_ctl_text
or !Flag.show_trying
or
338 !Flag.show_transinfo
or !Flag_cocci.show_binding_in_out
341 let name = i_to_s rulenb
in
342 Common.pr_xxxxxxxxxxxxxxxxx
();
343 pr
("script rule " ^
name ^
" = ");
344 Common.pr_xxxxxxxxxxxxxxxxx
()
347 let show_or_not_ctl_text2 ctl ast rulenb
=
348 if !Flag_cocci.show_ctl_text
then begin
350 adjust_pp_with_indent
(fun () ->
351 Format.force_newline
();
352 Pretty_print_cocci.print_plus_flag
:= true;
353 Pretty_print_cocci.print_minus_flag
:= true;
354 Pretty_print_cocci.unparse ast
;
359 adjust_pp_with_indent
(fun () ->
360 Format.force_newline
();
361 Pretty_print_engine.pp_ctlcocci
362 !Flag_cocci.show_mcodekind_in_ctl
!Flag_cocci.inline_let_ctl ctl
;
366 let show_or_not_ctl_text a b c
=
367 Common.profile_code
"show_xxx" (fun () -> show_or_not_ctl_text2 a b c
)
371 (* running information *)
372 let get_celem celem
: string =
374 Ast_c.Definition
({Ast_c.f_name
= namefuncs
;},_
) ->
375 Ast_c.str_of_name namefuncs
377 (Ast_c.DeclList
([{Ast_c.v_namei
= Some
(name, _
);}, _
], _
)) ->
378 Ast_c.str_of_name
name
381 let show_or_not_celem2 prelude celem
=
384 | Ast_c.Definition
({Ast_c.f_name
= namefuncs
},_
) ->
385 let funcs = Ast_c.str_of_name namefuncs
in
386 Flag.current_element
:= funcs;
387 (" function: ",funcs)
389 (Ast_c.DeclList
([{Ast_c.v_namei
= Some
(name,_
)}, _
], _
)) ->
390 let s = Ast_c.str_of_name
name in
391 Flag.current_element
:= s;
394 Flag.current_element
:= "something_else";
395 (" ","something else");
397 if !Flag.show_trying
then pr2
(prelude ^ tag ^ trying
)
399 let show_or_not_celem a b
=
400 Common.profile_code
"show_xxx" (fun () -> show_or_not_celem2 a b
)
403 let show_or_not_trans_info2 trans_info
=
404 (* drop witness tree indices for printing *)
406 List.map
(function (index
,trans_info) -> trans_info) trans_info in
407 if !Flag.show_transinfo
then begin
408 if null
trans_info then pr2
"transformation info is empty"
410 pr2
"transformation info returned:";
412 List.sort
(function (i1
,_
,_
) -> function (i2
,_
,_
) -> compare i1 i2
)
416 trans_info +> List.iter
(fun (i
, subst
, re
) ->
417 pr2
("transform state: " ^
(Common.i_to_s i
));
419 adjust_pp_with_indent_and_header
"with rule_elem: " (fun () ->
420 Pretty_print_cocci.print_plus_flag
:= true;
421 Pretty_print_cocci.print_minus_flag
:= true;
422 Pretty_print_cocci.rule_elem
"" re
;
424 adjust_pp_with_indent_and_header
"with binding: " (fun () ->
425 Pretty_print_engine.pp_binding subst
;
432 let show_or_not_trans_info a
=
433 Common.profile_code
"show_xxx" (fun () -> show_or_not_trans_info2 a
)
437 let show_or_not_binding2 s binding
=
438 if !Flag_cocci.show_binding_in_out
then begin
439 adjust_pp_with_indent_and_header
("binding " ^
s ^
" = ") (fun () ->
440 Pretty_print_engine.pp_binding binding
443 let show_or_not_binding a b
=
444 Common.profile_code
"show_xxx" (fun () -> show_or_not_binding2 a b
)
448 (*****************************************************************************)
449 (* Some helper functions *)
450 (*****************************************************************************)
452 let worth_trying cfiles tokens
=
453 (* drop the following line for a list of list by rules. since we don't
454 allow multiple minirules, all the tokens within a rule should be in
455 a single CFG entity *)
456 match (!Flag_cocci.windows
,tokens
) with
457 (true,_
) | (_
,None
) -> true
459 (* could also modify the code in get_constants.ml *)
460 let tokens = tokens +> List.map
(fun s ->
462 | _
when s =~
"^[A-Za-z_][A-Za-z_0-9]*$" ->
465 | _
when s =~
"^[A-Za-z_]" ->
468 | _
when s =~
".*[A-Za-z_]$" ->
473 let com = sprintf
"egrep -q '(%s)' %s" (join
"|" tokens) (join
" " cfiles
)
475 (match Sys.command
com with
476 | 0 (* success *) -> true
479 then Printf.printf
"grep failed: %s\n" com);
480 false (* no match, so not worth trying *))
482 let check_macro_in_sp_and_adjust = function
485 tokens +> List.iter
(fun s ->
486 if Hashtbl.mem
!Parse_c._defs
s
488 if !Flag_cocci.verbose_cocci
then begin
489 pr2
"warning: macro in semantic patch was in macro definitions";
490 pr2
("disabling macro expansion for " ^
s);
492 Hashtbl.remove
!Parse_c._defs
s
496 let contain_loop gopt
=
499 g#nodes#tolist
+> List.exists
(fun (xi
, node
) ->
500 Control_flow_c.extract_is_loop node
502 | None
-> true (* means nothing, if no g then will not model check *)
506 let sp_contain_typed_metavar_z toplevel_list_list
=
507 let bind x y
= x
or y
in
508 let option_default = false in
509 let mcode _ _
= option_default in
510 let donothing r k e
= k e
in
512 let expression r k e
=
513 match Ast_cocci.unwrap e
with
514 | Ast_cocci.MetaExpr
(_
,_
,_
,Some t
,_
,_
) -> true
515 | Ast_cocci.MetaExpr
(_
,_
,_
,_
,Ast_cocci.LocalID
,_
) -> true
520 Visitor_ast.combiner bind option_default
521 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
522 donothing donothing donothing donothing donothing
523 donothing expression donothing donothing donothing donothing donothing
524 donothing donothing donothing donothing donothing
526 toplevel_list_list
+>
528 (function (nm
,_
,rule
) ->
529 (List.exists
combiner.Visitor_ast.combiner_top_level rule
))
531 let sp_contain_typed_metavar rules
=
532 sp_contain_typed_metavar_z
536 Ast_cocci.CocciRule
(a
,b
,c
,d
,_
) -> (a
,b
,c
)
537 | _
-> failwith
"error in filter")
541 Ast_cocci.CocciRule
(a
,b
,c
,d
,Ast_cocci.Normal
) -> true
547 (* finding among the #include the one that we need to parse
548 * because they may contain useful type definition or because
549 * we may have to modify them
551 * For the moment we base in part our heuristic on the name of the file, e.g.
552 * serio.c is related we think to #include <linux/serio.h>
554 let rec search_include_path searchlist relpath
=
555 match searchlist
with
558 let file = Filename.concat hd relpath
in
559 if Sys.file_exists
file then
562 search_include_path tail relpath
564 let interpret_include_path relpath
=
566 match !Flag_cocci.include_path
with
570 search_include_path searchlist relpath
572 let (includes_to_parse
:
573 (Common.filename
* Parse_c.program2
) list
->
574 Flag_cocci.include_options
-> 'a
) = fun xs choose_includes
->
575 match choose_includes
with
576 Flag_cocci.I_UNSPECIFIED
-> failwith
"not possible"
577 | Flag_cocci.I_NO_INCLUDES
-> []
581 [Flag_cocci.I_ALL_INCLUDES
; Flag_cocci.I_REALLY_ALL_INCLUDES
] in
582 xs +> List.map
(fun (file, cs
) ->
583 let dir = Common.dirname
file in
585 cs
+> Common.map_filter
(fun (c
,_info_item
) ->
589 {Ast_c.i_include
= ((x
,ii
)); i_rel_pos
= info_h_pos
;}) ->
592 let relpath = Common.join
"/" xs in
593 let f = Filename.concat
dir (relpath) in
594 if (Sys.file_exists
f) then
597 if !Flag_cocci.relax_include_path
598 (* for our tests, all the files are flat in the current dir *)
600 let attempt2 = Filename.concat
dir (Common.last
xs) in
601 if not
(Sys.file_exists
attempt2) && all_includes
603 interpret_include_path relpath
606 if all_includes then interpret_include_path relpath
609 | Ast_c.NonLocal
xs ->
610 let relpath = Common.join
"/" xs in
612 Common.fileprefix
(Common.last
xs) =$
= Common.fileprefix
file
614 interpret_include_path relpath
616 | Ast_c.Weird _
-> None
620 +> (fun x
-> (List.rev
(Common.uniq
(List.rev x
)))) (*uniq keeps last*)
622 let rec interpret_dependencies local global
= function
623 Ast_cocci.Dep
s -> List.mem
s local
624 | Ast_cocci.AntiDep
s ->
625 (if !Flag_ctl.steps
!= None
626 then failwith
"steps and ! dependency incompatible");
627 not
(List.mem
s local
)
628 | Ast_cocci.EverDep
s -> List.mem
s global
629 | Ast_cocci.NeverDep
s ->
630 (if !Flag_ctl.steps
!= None
631 then failwith
"steps and ! dependency incompatible");
632 not
(List.mem
s global
)
633 | Ast_cocci.AndDep
(s1
,s2
) ->
634 (interpret_dependencies local global s1
) &&
635 (interpret_dependencies local global s2
)
636 | Ast_cocci.OrDep
(s1
,s2
) ->
637 (interpret_dependencies local global s1
) or
638 (interpret_dependencies local global s2
)
639 | Ast_cocci.NoDep
-> true
640 | Ast_cocci.FailDep
-> false
642 let rec print_dependencies str local global dep
=
643 if !Flag_cocci.show_dependencies
648 let rec loop = function
649 Ast_cocci.Dep
s | Ast_cocci.AntiDep
s ->
650 if not
(List.mem
s !seen)
654 then pr2
(s^
" satisfied")
655 else pr2
(s^
" not satisfied");
658 | Ast_cocci.EverDep
s | Ast_cocci.NeverDep
s ->
659 if not
(List.mem
s !seen)
663 then pr2
(s^
" satisfied")
664 else pr2
(s^
" not satisfied");
667 | Ast_cocci.AndDep
(s1
,s2
) ->
670 | Ast_cocci.OrDep
(s1
,s2
) ->
673 | Ast_cocci.NoDep
-> ()
674 | Ast_cocci.FailDep
-> pr2
"False not satisfied" in
678 (* --------------------------------------------------------------------- *)
679 (* #include relative position in the file *)
680 (* --------------------------------------------------------------------- *)
682 (* compute the set of new prefixes
684 * "a/b/x"; (* in fact it is now a list of string so ["a";"b";"x"] *)
688 * it would give
for the first element
689 * ""; "a"; "a/b"; "a/b/x"
693 * update
: if the
include is inside a ifdef a put nothing
. cf
-test incl
.
694 * this is because we dont want code added inside ifdef
.
697 let compute_new_prefixes xs =
698 xs +> Common.map_withenv
(fun already
xs ->
699 let subdirs_prefixes = Common.inits
xs in
700 let new_first = subdirs_prefixes +> List.filter
(fun x
->
701 not
(List.mem x already
)
710 (* does via side effect on the ref in the Include in Ast_c *)
711 let rec update_include_rel_pos cs
=
712 let only_include = cs
+> Common.map_filter
(fun c
->
714 | Ast_c.CppTop
(Ast_c.Include
{Ast_c.i_include
= ((x
,_
));
716 i_is_in_ifdef
= inifdef
}) ->
718 | Ast_c.Weird _
-> None
727 let (locals
, nonlocals
) =
728 only_include +> Common.partition_either
(fun (c
, aref
) ->
730 | Ast_c.Local x
-> Left
(x
, aref
)
731 | Ast_c.NonLocal x
-> Right
(x
, aref
)
732 | Ast_c.Weird x
-> raise Impossible
735 update_rel_pos_bis locals
;
736 update_rel_pos_bis nonlocals
;
738 and update_rel_pos_bis
xs =
739 let xs'
= List.map fst
xs in
740 let the_first = compute_new_prefixes xs'
in
741 let the_last = List.rev
(compute_new_prefixes (List.rev
xs'
)) in
742 let merged = Common.zip
xs (Common.zip
the_first the_last) in
743 merged +> List.iter
(fun ((x
, aref
), (the_first, the_last)) ->
746 Ast_c.first_of
= the_first;
747 Ast_c.last_of
= the_last;
752 (*****************************************************************************)
753 (* All the information needed around the C elements and Cocci rules *)
754 (*****************************************************************************)
756 type toplevel_c_info
= {
757 ast_c
: Ast_c.toplevel
; (* contain refs so can be modified *)
758 tokens_c
: Parser_c.token list
;
761 flow
: Control_flow_c.cflow
option; (* it's the "fixed" flow *)
764 env_typing_before
: TAC.environment
;
765 env_typing_after
: TAC.environment
;
767 was_modified
: bool ref;
774 dependencies
: Ast_cocci.dependency
;
775 used_after
: Ast_cocci.meta_name list
;
777 was_matched
: bool ref;
780 type toplevel_cocci_info_script_rule
= {
783 (Ast_cocci.script_meta_name
* Ast_cocci.meta_name
*
784 Ast_cocci.metavar
) list
*
785 Ast_cocci.meta_name list
(*fresh vars*) *
789 scr_rule_info
: rule_info
;
792 type toplevel_cocci_info_cocci_rule
= {
793 ctl
: Lib_engine.ctlcocci
* (CCI.pred list list
);
794 metavars
: Ast_cocci.metavar list
;
795 ast_rule
: Ast_cocci.rule
;
796 isexp
: bool; (* true if + code is an exp, only for Flag.make_hrule *)
798 (* There are also some hardcoded rule names in parse_cocci.ml:
799 * let reserved_names = ["all";"optional_storage";"optional_qualifier"]
801 dropped_isos
: string list
;
802 free_vars
: Ast_cocci.meta_name list
;
803 negated_pos_vars
: Ast_cocci.meta_name list
;
804 positions
: Ast_cocci.meta_name list
;
806 ruletype
: Ast_cocci.ruletype
;
808 rule_info
: rule_info
;
811 type toplevel_cocci_info
=
812 ScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
813 | InitialScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
814 | FinalScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
815 | CocciRuleCocciInfo
of toplevel_cocci_info_cocci_rule
817 type cocci_info
= toplevel_cocci_info list
* string list
option (* tokens *)
819 type kind_file
= Header
| Source
823 was_modified_once
: bool ref;
824 asts
: toplevel_c_info list
;
829 let g_contain_typedmetavar = ref false
832 let last_env_toplevel_c_info xs =
833 (Common.last
xs).env_typing_after
835 let concat_headers_and_c (ccs
: file_info list
)
836 : (toplevel_c_info
* string) list
=
837 (List.concat
(ccs
+> List.map
(fun x
->
838 x
.asts
+> List.map
(fun x'
->
841 let for_unparser xs =
842 xs +> List.map
(fun x
->
843 (x
.ast_c
, (x
.fullstring
, x
.tokens_c
)), Unparse_c.PPviastr
846 let gen_pdf_graph () =
847 (Ctl_engine.get_graph_files
()) +> List.iter
(fun outfile
->
848 Printf.printf
"Generation of %s%!" outfile
;
849 let filename_stack = Ctl_engine.get_graph_comp_files outfile
in
850 List.iter
(fun filename
->
851 ignore
(Unix.system
("dot " ^ filename ^
" -Tpdf -o " ^ filename ^
".pdf;"))
853 let (head
,tail
) = (List.hd
filename_stack, List.tl
filename_stack) in
854 ignore
(Unix.system
("cp " ^ head ^
".pdf " ^ outfile ^
".pdf;"));
855 tail
+> List.iter
(fun filename
->
856 ignore
(Unix.system
("mv " ^ outfile ^
".pdf /tmp/tmp.pdf;"));
857 ignore
(Unix.system
("pdftk " ^ filename ^
".pdf /tmp/tmp.pdf cat output " ^ outfile ^
".pdf"));
859 ignore
(Unix.system
("rm /tmp/tmp.pdf;"));
860 List.iter
(fun filename
->
861 ignore
(Unix.system
("rm " ^ filename ^
" " ^ filename ^
".pdf;"))
863 Printf.printf
" - Done\n")
865 let local_python_code =
866 "from coccinelle import *\n"
869 "import coccinelle\n"^
871 "import coccilib.org\n"^
872 "import coccilib.report\n" ^
876 let make_init lang code rule_info
=
879 scr_ast_rule
= (lang
, mv, [], code
);
881 script_code
= (if lang
= "python" then python_code else "") ^code
;
882 scr_rule_info
= rule_info
;
885 (* --------------------------------------------------------------------- *)
886 let prepare_cocci ctls free_var_lists negated_pos_lists
887 (ua
,fua
,fuas
) positions_list metavars astcocci
=
889 let gathered = Common.index_list_1
890 (zip
(zip
(zip
(zip
(zip
(zip
(zip
(zip ctls metavars
) astcocci
)
892 negated_pos_lists
) ua
) fua
) fuas
) positions_list
)
895 (fun (((((((((ctl_toplevel_list
,metavars
),ast
),free_var_list
),
896 negated_pos_list
),ua
),fua
),fuas
),positions_list
),rulenb
) ->
898 let build_rule_info rulename deps
=
899 {rulename
= rulename
;
901 used_after
= (List.hd ua
) @ (List.hd fua
);
903 was_matched
= ref false;} in
905 let is_script_rule r
=
907 Ast_cocci.ScriptRule _
908 | Ast_cocci.InitialScriptRule _
| Ast_cocci.FinalScriptRule _
-> true
911 if not
(List.length ctl_toplevel_list
=|= 1) && not
(is_script_rule ast
)
912 then failwith
"not handling multiple minirules";
915 Ast_cocci.ScriptRule
(name,lang
,deps
,mv,script_vars
,code
) ->
918 scr_ast_rule
= (lang
, mv, script_vars
, code
);
921 scr_rule_info
= build_rule_info name deps
;
923 in ScriptRuleCocciInfo
r
924 | Ast_cocci.InitialScriptRule
(name,lang
,deps
,code
) ->
925 let r = make_init lang code
(build_rule_info name deps
) in
926 InitialScriptRuleCocciInfo
r
927 | Ast_cocci.FinalScriptRule
(name,lang
,deps
,code
) ->
931 scr_ast_rule
= (lang
, mv, [], code
);
934 scr_rule_info
= build_rule_info name deps
;
936 in FinalScriptRuleCocciInfo
r
937 | Ast_cocci.CocciRule
938 (rulename
,(dependencies
,dropped_isos
,z
),restast
,isexp
,ruletype
) ->
941 ctl
= List.hd ctl_toplevel_list
;
944 isexp
= List.hd isexp
;
945 dropped_isos
= dropped_isos
;
946 free_vars
= List.hd free_var_list
;
947 negated_pos_vars
= List.hd negated_pos_list
;
948 positions
= List.hd positions_list
;
950 rule_info
= build_rule_info rulename dependencies
;
954 (* --------------------------------------------------------------------- *)
956 let build_info_program cprogram env
=
958 let (cs
, parseinfos
) =
959 Common.unzip cprogram
in
962 parseinfos
+> List.map
(fun (s,toks
) -> toks
) +> List.flatten
in
964 (* I use cs' but really annotate_xxx work by doing side effects on cs *)
966 Comment_annotater_c.annotate_program
alltoks cs in
968 Type_annoter_c.annotate_program env
(*!g_contain_typedmetavar*) cs'
971 zip
cs_with_envs parseinfos
+> List.map
(fun ((c
, (enva
,envb
)), parseinfo
)->
972 let (fullstr
, tokens) = parseinfo
in
975 ast_to_flow_with_error_messages c
+>
976 Common.map_option
(fun flow ->
977 let flow = Ast_to_flow.annotate_loop_nodes
flow in
979 (* remove the fake nodes for julia *)
980 let fixed_flow = CCI.fix_flow_ctl
flow in
982 if !Flag_cocci.show_flow
then print_flow fixed_flow;
983 if !Flag_cocci.show_before_fixed_flow
then print_flow flow;
990 ast_c
= c
; (* contain refs so can be modified *)
992 fullstring
= fullstr
;
996 contain_loop = contain_loop flow;
998 env_typing_before
= enva
;
999 env_typing_after
= envb
;
1001 was_modified
= ref false;
1007 (* Optimisation. Try not unparse/reparse the whole file when have modifs *)
1008 let rebuild_info_program cs file isexp
=
1009 cs +> List.map
(fun c
->
1010 if !(c
.was_modified
)
1012 let file = Common.new_temp_file
"cocci_small_output" ".c" in
1014 [(c
.ast_c
, (c
.fullstring
, c
.tokens_c
)), Unparse_c.PPnormal
]
1017 (* Common.command2 ("cat " ^ file); *)
1018 let cprogram = cprogram_of_file file in
1019 let xs = build_info_program cprogram c
.env_typing_before
in
1021 (* TODO: assert env has not changed,
1022 * if yes then must also reparse what follows even if not modified.
1023 * Do that only if contain_typedmetavar of course, so good opti.
1025 (* Common.list_init xs *) (* get rid of the FinalDef *)
1031 let rebuild_info_c_and_headers ccs isexp
=
1032 ccs
+> List.iter
(fun c_or_h
->
1033 if c_or_h
.asts
+> List.exists
(fun c
-> !(c
.was_modified
))
1034 then c_or_h
.was_modified_once
:= true;
1036 ccs
+> List.map
(fun c_or_h
->
1039 rebuild_info_program c_or_h
.asts c_or_h
.full_fname isexp
}
1042 let rec prepare_h seen env hpath choose_includes
: file_info list
=
1043 if not
(Common.lfile_exists hpath
)
1046 pr2
("TYPE: header " ^ hpath ^
" not found");
1051 let h_cs = cprogram_of_file_cached hpath
in
1052 let local_includes =
1053 if choose_includes
=*= Flag_cocci.I_REALLY_ALL_INCLUDES
1056 (function x
-> not
(List.mem x
!seen))
1057 (includes_to_parse
[(hpath
,h_cs)] choose_includes
)
1059 seen := local_includes @ !seen;
1062 (List.map
(function x
-> prepare_h seen env x choose_includes
)
1064 let info_h_cs = build_info_program h_cs !env
in
1068 else last_env_toplevel_c_info info_h_cs;
1071 fname
= Common.basename hpath
;
1074 was_modified_once
= ref false;
1080 let prepare_c files choose_includes
: file_info list
=
1081 let cprograms = List.map
cprogram_of_file_cached files
in
1082 let includes = includes_to_parse
(zip files
cprograms) choose_includes
in
1083 let seen = ref includes in
1085 (* todo?: may not be good to first have all the headers and then all the c *)
1086 let env = ref !TAC.initial_env
in
1090 List.map
(function hpath
-> prepare_h seen env hpath choose_includes
) +>
1094 (zip files
cprograms) +>
1096 (function (file, cprogram) ->
1097 (* todo?: don't update env ? *)
1098 let cs = build_info_program cprogram !env in
1099 (* we do that only for the c, not for the h *)
1100 ignore
(update_include_rel_pos (cs +> List.map
(fun x
-> x
.ast_c
)));
1102 fname
= Common.basename
file;
1105 was_modified_once
= ref false;
1112 (*****************************************************************************)
1113 (* Processing the ctls and toplevel C elements *)
1114 (*****************************************************************************)
1116 (* The main algorithm =~
1117 * The algorithm is roughly:
1118 * for_all ctl rules in SP
1119 * for_all minirule in rule (no more)
1120 * for_all binding (computed during previous phase)
1121 * for_all C elements
1122 * match control flow of function vs minirule
1123 * with the binding and update the set of possible
1124 * bindings, and returned the possibly modified function.
1125 * pretty print modified C elements and reparse it.
1128 * On ne prends que les newbinding ou returned_any_state est vrai.
1129 * Si ca ne donne rien, on prends ce qu'il y avait au depart.
1130 * Mais au nouveau depart de quoi ?
1131 * - si ca donne rien apres avoir traité toutes les fonctions avec ce binding ?
1132 * - ou alors si ca donne rien, apres avoir traité toutes les fonctions
1133 * avec tous les bindings du round d'avant ?
1135 * Julia pense qu'il faut prendre la premiere solution.
1136 * Example: on a deux environnements candidats, E1 et E2 apres avoir traité
1137 * la regle ctl 1. On arrive sur la regle ctl 2.
1138 * E1 ne donne rien pour la regle 2, on garde quand meme E1 pour la regle 3.
1139 * E2 donne un match a un endroit et rend E2' alors on utilise ca pour
1142 * I have not to look at used_after_list to decide to restart from
1143 * scratch. I just need to look if the binding list is empty.
1144 * Indeed, let's suppose that a SP have 3 regions/rules. If we
1145 * don't find a match for the first region, then if this first
1146 * region does not bind metavariable used after, that is if
1147 * used_after_list is empty, then mysat(), even if does not find a
1148 * match, will return a Left, with an empty transformation_info,
1149 * and so current_binding will grow. On the contrary if the first
1150 * region must bind some metavariables used after, and that we
1151 * dont find any such region, then mysat() will returns lots of
1152 * Right, and current_binding will not grow, and so we will have
1153 * an empty list of binding, and we will catch such a case.
1155 * opti: julia says that because the binding is
1156 * determined by the used_after_list, the items in the list
1157 * are kind of sorted, so could optimise the insert_set operations.
1161 (* r(ule), c(element in C code), e(nvironment) *)
1164 let rec loop k
= function
1168 then Some
(x
, function n
-> k
(n
:: xs))
1169 else loop (function vs
-> k
(x
:: vs
)) xs in
1170 loop (function x
-> x
) l
1172 let merge_env new_e old_e
=
1175 (function (ext
,old_e
) ->
1176 function (e
,rules
) as elem
->
1177 match findk (function (e1
,_
) -> e
=*= e1
) old_e
with
1178 None
-> (elem
:: ext
,old_e
)
1179 | Some
((_
,old_rules
),k
) ->
1180 (ext
,k
(e
,Common.union_set rules old_rules
)))
1182 old_e
@ (List.rev ext
)
1184 let contains_binding e
(_
,(r,m
),_
) =
1186 let _ = List.find
(function ((re
, rm
), _) -> r =*= re
&& m
=$
= rm
) e
in
1188 with Not_found
-> false
1190 let python_application mv ve script_vars
r =
1194 ((Some x
,None
),y
,z
) -> (x
,y
,z
)
1197 (Printf.sprintf
"unexpected ast metavar in rule %s"
1198 r.scr_rule_info
.rulename
))
1201 Pycocci.build_classes
(List.map
(function (x
,y
) -> x
) ve
);
1202 Pycocci.construct_variables
mv ve
;
1203 Pycocci.construct_script_variables script_vars
;
1204 let _ = Pycocci.pyrun_simplestring
(local_python_code ^
r.script_code
) in
1205 if !Pycocci.inc_match
1206 then Some
(Pycocci.retrieve_script_variables script_vars
)
1208 with Pycocci.Pycocciexception
->
1209 (pr2
("Failure in " ^
r.scr_rule_info
.rulename
);
1210 raise
Pycocci.Pycocciexception
)
1212 let ocaml_application mv ve script_vars
r =
1215 Run_ocamlcocci.run
mv ve script_vars
1216 r.scr_rule_info
.rulename
r.script_code
in
1217 if !Coccilib.inc_match
1218 then Some
script_vals
1220 with e
-> (pr2
("Failure in " ^
r.scr_rule_info
.rulename
); raise e
)
1222 let apply_script_rule r cache newes e rules_that_have_matched
1223 rules_that_have_ever_matched script_application
=
1224 Common.profile_code
r.language
(fun () ->
1225 show_or_not_scr_rule_name r.scr_rule_info
.ruleid
;
1226 if not
(interpret_dependencies rules_that_have_matched
1227 !rules_that_have_ever_matched
r.scr_rule_info
.dependencies
)
1230 print_dependencies "dependencies for script not satisfied:"
1231 rules_that_have_matched
1232 !rules_that_have_ever_matched
r.scr_rule_info
.dependencies
;
1233 show_or_not_binding "in environment" e
;
1234 (cache
, (e
, rules_that_have_matched
)::newes
)
1238 let (_, mv, script_vars
, _) = r.scr_ast_rule
in
1240 (List.map
(function (n
,v
) -> (("virtual",n
),Ast_c.MetaIdVal
(v
,[])))
1241 !Flag.defined_virtual_env
) @ e
in
1242 let not_bound x
= not
(contains_binding ve x
) in
1243 (match List.filter
not_bound mv with
1245 let relevant_bindings =
1247 (function ((re
,rm
),_) ->
1248 List.exists
(function (_,(r,m
),_) -> r =*= re
&& m
=$
= rm
) mv)
1251 match List.assoc
relevant_bindings cache
with
1252 None
-> (cache
,newes
)
1253 | Some
script_vals ->
1255 "dependencies for script satisfied, but cached:"
1256 rules_that_have_matched
1257 !rules_that_have_ever_matched
1258 r.scr_rule_info
.dependencies
;
1259 show_or_not_binding "in" e
;
1260 (* env might be bigger than what was cached against, so have to
1261 merge with newes anyway *)
1262 let new_e = (List.combine script_vars
script_vals) @ e
in
1266 (fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1267 (cache
,merge_env [(new_e, rules_that_have_matched
)] newes
)
1270 print_dependencies "dependencies for script satisfied:"
1271 rules_that_have_matched
1272 !rules_that_have_ever_matched
1273 r.scr_rule_info
.dependencies
;
1274 show_or_not_binding "in" e
;
1275 match script_application
mv ve script_vars
r with
1277 (* failure means we should drop e, no new bindings *)
1278 (((relevant_bindings,None
) :: cache
), newes
)
1279 | Some
script_vals ->
1281 List.map
(function x
-> Ast_c.MetaIdVal
(x
,[]))
1284 (List.combine script_vars
script_vals) @ e
in
1288 (fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1289 r.scr_rule_info
.was_matched
:= true;
1290 (((relevant_bindings,Some
script_vals) :: cache
),
1293 r.scr_rule_info
.rulename
:: rules_that_have_matched
)]
1297 (if !Flag_cocci.show_dependencies
1299 let m2c (_,(r,x
),_) = r^
"."^x
in
1300 pr2
(Printf.sprintf
"script not applied: %s not bound"
1301 (String.concat
", " (List.map
m2c unbound
))));
1305 (fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1306 (cache
, merge_env [(e, rules_that_have_matched
)] newes
))
1309 let rec apply_cocci_rule r rules_that_have_ever_matched es
1310 (ccs
:file_info list
ref) =
1311 Common.profile_code
r.rule_info
.rulename
(fun () ->
1312 show_or_not_rule_name r.ast_rule
r.rule_info
.ruleid
;
1313 show_or_not_ctl_text r.ctl
r.ast_rule
r.rule_info
.ruleid
;
1315 let reorganized_env =
1316 reassociate_positions
r.free_vars
r.negated_pos_vars
!es
in
1318 (* looping over the environments *)
1319 let (_,newes
(* envs for next round/rule *)) =
1321 (function (cache
,newes
) ->
1322 function ((e,rules_that_have_matched
),relevant_bindings) ->
1323 if not
(interpret_dependencies rules_that_have_matched
1324 !rules_that_have_ever_matched
1325 r.rule_info
.dependencies
)
1329 ("dependencies for rule "^
r.rule_info
.rulename^
1331 rules_that_have_matched
1332 !rules_that_have_ever_matched
r.rule_info
.dependencies
;
1333 show_or_not_binding "in environment" e;
1338 (fun (s,v
) -> List.mem
s r.rule_info
.used_after
),
1339 rules_that_have_matched
)]
1344 try List.assoc
relevant_bindings cache
1348 ("dependencies for rule "^
r.rule_info
.rulename^
1350 rules_that_have_matched
1351 !rules_that_have_ever_matched
1352 r.rule_info
.dependencies
;
1353 show_or_not_binding "in" e;
1354 show_or_not_binding "relevant in" relevant_bindings;
1356 (* applying the rule *)
1357 (match r.ruletype
with
1359 (* looping over the functions and toplevel elements in
1362 (concat_headers_and_c !ccs
+>
1363 List.fold_left
(fun children_e
(c
,f) ->
1366 (* does also some side effects on c and r *)
1368 process_a_ctl_a_env_a_toplevel
r
1369 relevant_bindings c
f in
1370 match processed with
1371 | None
-> children_e
1372 | Some newbindings
->
1375 (fun children_e newbinding
->
1376 if List.mem newbinding children_e
1378 else newbinding
:: children_e
)
1382 | Ast_cocci.Generated
->
1383 process_a_generated_a_env_a_toplevel
r
1384 relevant_bindings !ccs
;
1387 let old_bindings_to_keep =
1391 (fun (s,v
) -> List.mem
s r.rule_info
.used_after
)) in
1393 if null
new_bindings
1396 (*use the old bindings, specialized to the used_after_list*)
1397 if !Flag_ctl.partial_match
1400 "Empty list of bindings, I will restart from old env\n";
1401 [(old_bindings_to_keep,rules_that_have_matched
)]
1404 (* combine the new bindings with the old ones, and
1405 specialize to the used_after_list *)
1406 let old_variables = List.map fst
old_bindings_to_keep in
1407 (* have to explicitly discard the inherited variables
1408 because we want the inherited value of the positions
1409 variables not the extended one created by
1410 reassociate_positions. want to reassociate freshly
1411 according to the free variables of each rule. *)
1412 let new_bindings_to_add =
1418 (* see comment before combine_pos *)
1419 (s,Ast_c.MetaPosValList
[]) -> false
1421 List.mem
s r.rule_info
.used_after
&&
1422 not
(List.mem
s old_variables)))) in
1424 (function new_binding_to_add
->
1427 old_bindings_to_keep new_binding_to_add
),
1428 r.rule_info
.rulename
::rules_that_have_matched
))
1429 new_bindings_to_add in
1430 ((relevant_bindings,new_bindings)::cache
,
1431 merge_env new_e newes
))
1432 ([],[]) reorganized_env in (* end iter es *)
1433 if !(r.rule_info
.was_matched
)
1434 then Common.push2
r.rule_info
.rulename rules_that_have_ever_matched
;
1438 (* apply the tagged modifs and reparse *)
1439 if not
!Flag.sgrep_mode2
1440 then ccs
:= rebuild_info_c_and_headers !ccs
r.isexp
)
1442 and reassociate_positions free_vars negated_pos_vars envs
=
1443 (* issues: isolate the bindings that are relevant to a given rule.
1444 separate out the position variables
1445 associate all of the position variables for a given set of relevant
1446 normal variable bindings with each set of relevant normal variable
1447 bindings. Goal: if eg if@p (E) matches in two places, then both inherited
1448 occurrences of E should see both bindings of p, not just its own.
1449 Otherwise, a position constraint for something that matches in two
1450 places will never be useful, because the position can always be
1451 different from the other one. *)
1455 List.filter
(function (x
,_) -> List.mem x free_vars
) e)
1457 let splitted_relevant =
1458 (* separate the relevant variables into the non-position ones and the
1463 (function (non_pos
,pos
) ->
1464 function (v
,_) as x
->
1465 if List.mem v negated_pos_vars
1466 then (non_pos
,x
::pos
)
1467 else (x
::non_pos
,pos
))
1470 let splitted_relevant =
1472 (function (non_pos
,pos
) ->
1473 (List.sort compare non_pos
,List.sort compare pos
))
1474 splitted_relevant in
1477 (function non_pos
->
1479 if List.mem np non_pos
then non_pos
else np
::non_pos
)
1480 [] splitted_relevant in
1481 let extended_relevant =
1482 (* extend the position variables with the values found at other identical
1483 variable bindings *)
1485 (function non_pos
->
1488 (function (other_non_pos
,other_pos
) ->
1489 (* do we want equal? or just somehow compatible? eg non_pos
1490 binds only E, but other_non_pos binds both E and E1 *)
1491 non_pos
=*= other_non_pos
)
1492 splitted_relevant in
1496 (combine_pos negated_pos_vars
1497 (List.map
(function (_,x
) -> x
) others)))))
1500 (List.map
(function (non_pos
,_) -> List.assoc non_pos
extended_relevant)
1503 (* If the negated posvar is not bound at all, this function will
1504 nevertheless bind it to []. If we get rid of these bindings, then the
1505 matching of the term the position variable with the constraints will fail
1506 because some variables are unbound. So we let the binding be [] and then
1507 we will have to clean these up afterwards. This should be the only way
1508 that a position variable can have an empty binding. *)
1509 and combine_pos negated_pos_vars
others =
1515 (function positions ->
1516 function other_list
->
1518 match List.assoc posvar other_list
with
1519 Ast_c.MetaPosValList l1
->
1520 Common.union_set l1
positions
1521 | _ -> failwith
"bad value for a position variable"
1522 with Not_found
-> positions)
1524 (posvar
,Ast_c.MetaPosValList
positions))
1527 and process_a_generated_a_env_a_toplevel2
r env = function
1532 (rule
,_) when rule
=$
= r.rule_info
.rulename
-> false
1533 | (_,"ARGS") -> false
1536 let env_domain = List.map
(function (nm
,vl
) -> nm
) env in
1540 let (rl
,_) = Ast_cocci.get_meta_name md
in rl
=$
= r.rule_info
.rulename
)
1542 if Common.include_set
free_vars env_domain
1543 then Unparse_hrule.pp_rule
metavars r.ast_rule
env cfile
.full_fname
1544 | _ -> failwith
"multiple files not supported"
1546 and process_a_generated_a_env_a_toplevel rule
env ccs
=
1547 Common.profile_code
"process_a_ctl_a_env_a_toplevel"
1548 (fun () -> process_a_generated_a_env_a_toplevel2 rule
env ccs
)
1550 (* does side effects on C ast and on Cocci info rule *)
1551 and process_a_ctl_a_env_a_toplevel2
r e c
f =
1552 indent_do
(fun () ->
1553 show_or_not_celem "trying" c
.ast_c
;
1554 Flag.currentfile
:= Some
(f ^
":" ^
get_celem c
.ast_c
);
1555 let (trans_info, returned_any_states
, inherited_bindings
, newbindings
) =
1556 Common.save_excursion
Flag_ctl.loop_in_src_code
(fun () ->
1557 Flag_ctl.loop_in_src_code
:= !Flag_ctl.loop_in_src_code
||c
.contain_loop;
1559 (***************************************)
1560 (* !Main point! The call to the engine *)
1561 (***************************************)
1562 let model_ctl = CCI.model_for_ctl
r.dropped_isos
(Common.some c
.flow) e
1563 in CCI.mysat
model_ctl r.ctl
(r.rule_info
.used_after
, e)
1566 if not returned_any_states
1569 show_or_not_celem "found match in" c
.ast_c
;
1570 show_or_not_trans_info trans_info;
1571 List.iter
(show_or_not_binding "out") newbindings
;
1573 r.rule_info
.was_matched
:= true;
1575 if not
(null
trans_info) &&
1576 not
(!Flag.sgrep_mode2
&& not
!Flag_cocci.show_diff
)
1578 c
.was_modified
:= true;
1580 (* les "more than one var in a decl" et "already tagged token"
1581 * font crasher coccinelle. Si on a 5 fichiers, donc on a 5
1582 * failed. Le try limite le scope des crashes pendant la
1583 * trasformation au fichier concerne. *)
1585 (* modify ast via side effect *)
1586 ignore
(Transformation_c.transform
r.rule_info
.rulename
r.dropped_isos
1587 inherited_bindings
trans_info (Common.some c
.flow));
1588 with Timeout
-> raise Timeout
| UnixExit i
-> raise
(UnixExit i
)
1591 Some
(List.map
(function x
-> x
@inherited_bindings
) newbindings
)
1595 and process_a_ctl_a_env_a_toplevel a b c
f=
1596 Common.profile_code
"process_a_ctl_a_env_a_toplevel"
1597 (fun () -> process_a_ctl_a_env_a_toplevel2 a b c
f)
1600 let rec bigloop2 rs
(ccs
: file_info list
) =
1601 let init_es = [(Ast_c.emptyMetavarsBinding
,[])] in
1602 let es = ref init_es in
1603 let ccs = ref ccs in
1604 let rules_that_have_ever_matched = ref [] in
1606 (* looping over the rules *)
1607 rs
+> List.iter
(fun r ->
1609 InitialScriptRuleCocciInfo
r | FinalScriptRuleCocciInfo
r -> ()
1610 | ScriptRuleCocciInfo
r ->
1611 if !Flag_cocci.show_ctl_text
then begin
1612 Common.pr_xxxxxxxxxxxxxxxxx
();
1613 pr
("script: " ^
r.language
);
1614 Common.pr_xxxxxxxxxxxxxxxxx
();
1616 adjust_pp_with_indent
(fun () ->
1617 Format.force_newline
();
1618 let (l,mv,script_vars
,code
) = r.scr_ast_rule
in
1619 let nm = r.scr_rule_info
.rulename
in
1620 let deps = r.scr_rule_info
.dependencies
in
1621 Pretty_print_cocci.unparse
1622 (Ast_cocci.ScriptRule
(nm,l,deps,mv,script_vars
,code
)));
1625 if !Flag.show_misc
then print_endline
"RESULT =";
1629 (function (cache
, newes
) ->
1630 function (e, rules_that_have_matched
) ->
1631 match r.language
with
1633 apply_script_rule r cache newes
e rules_that_have_matched
1634 rules_that_have_ever_matched python_application
1636 apply_script_rule r cache newes
e rules_that_have_matched
1637 rules_that_have_ever_matched ocaml_application
1639 concat_headers_and_c !ccs +> List.iter
(fun (c
,_) ->
1642 Printf.printf
"Flow: %s\r\nFlow!\r\n%!" c
.fullstring
);
1645 Printf.printf
"Unknown language: %s\n" r.language
;
1649 (if !(r.scr_rule_info
.was_matched
)
1651 Common.push2
r.scr_rule_info
.rulename
rules_that_have_ever_matched);
1653 es := newes
(*(if newes = [] then init_es else newes)*);
1654 | CocciRuleCocciInfo
r ->
1655 apply_cocci_rule r rules_that_have_ever_matched
1658 if !Flag.sgrep_mode2
1660 (* sgrep can lead to code that is not parsable, but we must
1661 * still call rebuild_info_c_and_headers to pretty print the
1662 * action (MINUS), so that later the diff will show what was
1663 * matched by sgrep. But we don't want the parsing error message
1664 * hence the following flag setting. So this code propably
1665 * will generate a NotParsedCorrectly for the matched parts
1666 * and the very final pretty print and diff will work
1668 Flag_parsing_c.verbose_parsing
:= false;
1669 ccs := rebuild_info_c_and_headers !ccs false
1671 !ccs (* return final C asts *)
1674 Common.profile_code
"bigloop" (fun () -> bigloop2 a b
)
1676 type init_final
= Initial
| Final
1678 let initial_final_bigloop2 ty rebuild
r =
1679 if !Flag_cocci.show_ctl_text
then
1681 Common.pr_xxxxxxxxxxxxxxxxx
();
1682 pr
((match ty
with Initial
-> "initial" | Final
-> "final") ^
": " ^
1684 Common.pr_xxxxxxxxxxxxxxxxx
();
1686 adjust_pp_with_indent
(fun () ->
1687 Format.force_newline
();
1688 Pretty_print_cocci.unparse
(rebuild
r.scr_ast_rule
r.scr_rule_info
.dependencies
));
1691 match r.language
with
1693 (* include_match makes no sense in an initial or final rule, although
1694 we have no way to prevent it *)
1695 let _ = apply_script_rule r [] [] [] [] (ref []) python_application in
1697 | "ocaml" when ty
= Initial
-> () (* nothing to do *)
1699 (* include_match makes no sense in an initial or final rule, although
1700 we have no way to prevent it *)
1701 let _ = apply_script_rule r [] [] [] [] (ref []) ocaml_application in
1704 failwith
("Unknown language for initial/final script: "^
1707 let initial_final_bigloop a b c
=
1708 Common.profile_code
"initial_final_bigloop"
1709 (fun () -> initial_final_bigloop2 a b c
)
1711 (*****************************************************************************)
1712 (* The main functions *)
1713 (*****************************************************************************)
1715 let pre_engine2 (coccifile
, isofile
) =
1716 show_or_not_cocci coccifile isofile
;
1717 Pycocci.set_coccifile coccifile
;
1720 if not
(Common.lfile_exists
isofile)
1722 pr2
("warning: Can't find default iso file: " ^
isofile);
1725 else Some
isofile in
1727 (* useful opti when use -dir *)
1728 let (metavars,astcocci
,
1729 free_var_lists
,negated_pos_lists
,used_after_lists
,
1730 positions_lists
,(toks
,_,_)) =
1731 sp_of_file coccifile
isofile in
1732 let ctls = ctls_of_ast astcocci used_after_lists positions_lists
in
1734 g_contain_typedmetavar := sp_contain_typed_metavar astcocci
;
1736 check_macro_in_sp_and_adjust toks
;
1738 show_or_not_ctl_tex astcocci
ctls;
1741 prepare_cocci ctls free_var_lists negated_pos_lists
1742 used_after_lists positions_lists
metavars astcocci
in
1744 let used_languages =
1746 (function languages
->
1748 ScriptRuleCocciInfo
(r) ->
1749 if List.mem
r.language languages
then
1752 r.language
::languages
1756 let initialized_languages =
1758 (function languages
->
1760 InitialScriptRuleCocciInfo
(r) ->
1761 (if List.mem
r.language languages
1764 ("double initializer found for "^
r.language
));
1765 if interpret_dependencies [] [] r.scr_rule_info
.dependencies
1768 initial_final_bigloop Initial
1769 (fun (x
,_,_,y
) -> fun deps ->
1770 Ast_cocci.InitialScriptRule
(r.scr_rule_info
.rulename
,x
,deps,y
))
1772 r.language
::languages
1778 let uninitialized_languages =
1780 (fun used
-> not
(List.mem used
initialized_languages))
1786 dependencies
= Ast_cocci.NoDep
;
1789 was_matched
= ref false;} in
1790 initial_final_bigloop Initial
1791 (fun (x
,_,_,y
) -> fun deps ->
1792 Ast_cocci.InitialScriptRule
("",x
,deps,y
))
1793 (make_init lgg
"" rule_info))
1794 uninitialized_languages;
1799 Common.profile_code
"pre_engine" (fun () -> pre_engine2 a
)
1801 let full_engine2 (cocci_infos,toks
) cfiles =
1803 show_or_not_cfiles cfiles;
1805 (* optimisation allowing to launch coccinelle on all the drivers *)
1806 if !Flag_cocci.worth_trying_opt
&& not
(worth_trying cfiles toks
)
1812 pr2
("No matches found for " ^
(Common.join
" " toks
)
1813 ^
"\nSkipping:" ^
(Common.join
" " cfiles)));
1814 cfiles +> List.map
(fun s -> s, None
)
1819 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1820 if !Flag.show_misc
then pr
"let's go";
1821 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1823 let choose_includes =
1824 match !Flag_cocci.include_options
with
1825 Flag_cocci.I_UNSPECIFIED
->
1826 if !g_contain_typedmetavar
1827 then Flag_cocci.I_NORMAL_INCLUDES
1828 else Flag_cocci.I_NO_INCLUDES
1830 let c_infos = prepare_c cfiles choose_includes in
1832 (* ! the big loop ! *)
1833 let c_infos'
= bigloop cocci_infos c_infos in
1835 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1836 if !Flag.show_misc
then pr
"Finished";
1837 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1838 if !Flag_ctl.graphical_trace
then gen_pdf_graph ();
1840 c_infos'
+> List.map
(fun c_or_h
->
1841 if !(c_or_h
.was_modified_once
)
1845 Common.new_temp_file
"cocci-output" ("-" ^ c_or_h
.fname
) in
1847 if c_or_h
.fkind
=*= Header
1848 then pr2
("a header file was modified: " ^ c_or_h
.fname
);
1850 (* and now unparse everything *)
1851 cfile_of_program (for_unparser c_or_h
.asts
) outfile;
1853 show_or_not_diff c_or_h
.fpath
outfile;
1856 if !Flag.sgrep_mode2
then None
else Some
outfile)
1858 else (c_or_h
.fpath
, None
))
1861 let full_engine a b
=
1862 Common.profile_code
"full_engine"
1863 (fun () -> let res = full_engine2 a b
in (*Gc.print_stat stderr; *)res)
1865 let post_engine2 (cocci_infos,_) =
1868 (function languages
->
1870 FinalScriptRuleCocciInfo
(r) ->
1871 (if List.mem
r.language languages
1872 then failwith
("double finalizer found for "^
r.language
));
1873 initial_final_bigloop Final
1874 (fun (x
,_,_,y
) -> fun deps ->
1875 Ast_cocci.FinalScriptRule
(r.scr_rule_info
.rulename
,x
,deps,y
))
1877 r.language
::languages
1883 Common.profile_code
"post_engine" (fun () -> post_engine2 a
)
1885 (*****************************************************************************)
1886 (* check duplicate from result of full_engine *)
1887 (*****************************************************************************)
1889 let check_duplicate_modif2 xs =
1890 (* opti: let groups = Common.groupBy (fun (a,resa) (b,resb) -> a =$= b) xs *)
1891 if !Flag_cocci.verbose_cocci
1892 then pr2
("Check duplication for " ^ i_to_s
(List.length
xs) ^
" files");
1894 let groups = Common.group_assoc_bykey_eff
xs in
1895 groups +> Common.map_filter
(fun (file, xs) ->
1897 | [] -> raise Impossible
1898 | [res] -> Some
(file, res)
1902 if not
(List.for_all
(fun res2
-> res2
=*= None
) xs)
1904 pr2
("different modification result for " ^
file);
1907 else Some
(file, None
)
1909 if not
(List.for_all
(fun res2
->
1913 let diff = Common.cmd_to_list
("diff -u -b -B "^
res^
" "^res2
)
1917 pr2
("different modification result for " ^
file);
1920 else Some
(file, Some
res)
1922 let check_duplicate_modif a
=
1923 Common.profile_code
"check_duplicate" (fun () -> check_duplicate_modif2 a
)