2 * Copyright 2005-2008, Ecole des Mines de Nantes, University of Copenhagen
3 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
4 * This file is part of Coccinelle.
6 * Coccinelle is free software: you can redistribute it and/or modify
7 * it under the terms of the GNU General Public License as published by
8 * the Free Software Foundation, according to version 2 of the License.
10 * Coccinelle is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 * GNU General Public License for more details.
15 * You should have received a copy of the GNU General Public License
16 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
18 * The authors reserve the right to distribute this or future versions of
19 * Coccinelle under other licenses.
25 module CCI
= Ctlcocci_integration
26 module TAC
= Type_annoter_c
28 (*****************************************************************************)
29 (* This file is a kind of driver. It gathers all the important functions
30 * from coccinelle in one place. The different entities in coccinelle are:
34 * - flow (contain nodes)
35 * - ctl (contain rule_elems)
36 * This file contains functions to transform one in another.
38 (*****************************************************************************)
40 (* --------------------------------------------------------------------- *)
42 (* --------------------------------------------------------------------- *)
43 let cprogram_of_file file
=
44 let (program2
, _stat
) = Parse_c.parse_print_error_heuristic file
in
47 let cprogram_of_file_cached file
=
48 let (program2
, _stat
) = Parse_c.parse_cache file
in
49 if !Flag_cocci.ifdef_to_if
51 program2
+> Parse_c.with_program2
(fun asts
->
52 Cpp_ast_c.cpp_ifdef_statementize asts
56 let cfile_of_program program2_with_ppmethod outf
=
57 Unparse_c.pp_program program2_with_ppmethod outf
59 (* for memoization, contains only one entry, the one for the SP *)
60 let _hparse = Hashtbl.create
101
61 let _hctl = Hashtbl.create
101
63 (* --------------------------------------------------------------------- *)
65 (* --------------------------------------------------------------------- *)
66 let sp_of_file2 file iso
=
67 Common.memoized
_hparse (file
, iso
) (fun () ->
68 Parse_cocci.process file iso
false)
69 let sp_of_file file iso
=
70 Common.profile_code
"parse cocci" (fun () -> sp_of_file2 file iso
)
73 (* --------------------------------------------------------------------- *)
75 (* --------------------------------------------------------------------- *)
77 Ograph_extended.print_ograph_mutable flow
"/tmp/test.dot" true
80 let ast_to_flow_with_error_messages2 x
=
82 try Ast_to_flow.ast_to_control_flow x
83 with Ast_to_flow.Error x
->
84 Ast_to_flow.report_error x
;
87 flowopt +> do_option
(fun flow
->
88 (* This time even if there is a deadcode, we still have a
89 * flow graph, so I can try the transformation and hope the
90 * deadcode will not bother us.
92 try Ast_to_flow.deadcode_detection flow
93 with Ast_to_flow.Error
(Ast_to_flow.DeadCode x
) ->
94 Ast_to_flow.report_error
(Ast_to_flow.DeadCode x
);
97 let ast_to_flow_with_error_messages a
=
98 Common.profile_code
"flow" (fun () -> ast_to_flow_with_error_messages2 a
)
101 (* --------------------------------------------------------------------- *)
103 (* --------------------------------------------------------------------- *)
104 let ctls_of_ast2 ast ua pos
=
106 (function ast
-> function (ua
,pos
) ->
110 else Asttoctl2.asttoctl ast ua pos
)
111 (Asttomember.asttomember ast ua
))
112 ast
(List.combine ua pos
)
114 let ctls_of_ast ast ua
=
115 Common.profile_code
"asttoctl2" (fun () -> ctls_of_ast2 ast ua
)
117 (*****************************************************************************)
118 (* Some debugging functions *)
119 (*****************************************************************************)
123 let show_or_not_cfile2 cfile
=
124 if !Flag_cocci.show_c
then begin
125 Common.pr2_xxxxxxxxxxxxxxxxx
();
126 pr2
("processing C file: " ^ cfile
);
127 Common.pr2_xxxxxxxxxxxxxxxxx
();
128 Common.command2
("cat " ^ cfile
);
130 let show_or_not_cfile a
=
131 Common.profile_code
"show_xxx" (fun () -> show_or_not_cfile2 a
)
133 let show_or_not_cfiles cfiles
= List.iter
show_or_not_cfile cfiles
136 let show_or_not_cocci2 coccifile isofile
=
137 if !Flag_cocci.show_cocci
then begin
138 Common.pr2_xxxxxxxxxxxxxxxxx
();
139 pr2
("processing semantic patch file: " ^ coccifile
);
140 isofile
+> (fun s
-> pr2
("with isos from: " ^ s
));
141 Common.pr2_xxxxxxxxxxxxxxxxx
();
142 Common.command2
("cat " ^ coccifile
);
145 let show_or_not_cocci a b
=
146 Common.profile_code
"show_xxx" (fun () -> show_or_not_cocci2 a b
)
151 let show_or_not_diff2 cfile outfile show_only_minus
=
152 if !Flag_cocci.show_diff
then begin
153 match Common.fst
(Compare_c.compare_default cfile outfile
) with
154 Compare_c.Correct
-> () (* diff only in spacing, etc *)
156 (* may need --strip-trailing-cr under windows *)
160 match !Flag_parsing_c.diff_lines
with
161 | None
-> "diff -u -p " ^ cfile ^
" " ^ outfile
162 | Some n
-> "diff -U "^n^
" -p "^cfile^
" "^outfile
in
164 let res = Common.cmd_to_list
line in
165 match (!Flag.patch
,res) with
166 (* create something that looks like the output of patch *)
167 (Some prefix
,minus_file
::plus_file
::rest
) ->
168 let drop_prefix file
=
172 (match Str.split
(Str.regexp prefix
) file
with
173 [base_file
] -> base_file
174 | _
-> failwith
"prefix not found in the old file name") in
176 match List.rev
(Str.split
(Str.regexp
" ") line) with
177 new_file
::old_file
::cmdrev
->
181 (List.rev
("/tmp/nothing" :: old_file
:: cmdrev
))
183 let old_base_file = drop_prefix old_file
in
186 (("b"^
old_base_file)::("a"^
old_base_file)::cmdrev
))
187 | _
-> failwith
"bad command" in
188 let (minus_line
,plus_line
) =
190 then (minus_file
,plus_file
)
192 match (Str.split
(Str.regexp
"[ \t]") minus_file
,
193 Str.split
(Str.regexp
"[ \t]") plus_file
) with
194 ("---"::old_file
::old_rest
,"+++"::new_file
::new_rest
) ->
195 let old_base_file = drop_prefix old_file
in
197 ("---"::("a"^
old_base_file)::old_rest
),
199 ("+++"::("b"^
old_base_file)::new_rest
))
202 (Printf.sprintf
"bad diff header lines: %s %s"
203 (String.concat
":" l1
) (String.concat
":" l2
)) in
204 diff_line::minus_line
::plus_line
::rest
206 xs +> List.iter
(fun s
->
207 if s
=~
"^\\+" && show_only_minus
211 let show_or_not_diff a b c
=
212 Common.profile_code
"show_xxx" (fun () -> show_or_not_diff2 a b c
)
215 (* the derived input *)
217 let show_or_not_ctl_tex2 astcocci ctls
=
218 if !Flag_cocci.show_ctl_tex
then begin
219 Ctltotex.totex
("/tmp/__cocci_ctl.tex") astcocci ctls
;
220 Common.command2
("cd /tmp; latex __cocci_ctl.tex; " ^
221 "dvips __cocci_ctl.dvi -o __cocci_ctl.ps;" ^
222 "gv __cocci_ctl.ps &");
224 let show_or_not_ctl_tex a b
=
225 Common.profile_code
"show_xxx" (fun () -> show_or_not_ctl_tex2 a b
)
229 let show_or_not_rule_name ast rulenb
=
230 if !Flag_cocci.show_ctl_text
or !Flag.show_trying
or
231 !Flag_cocci.show_transinfo
or !Flag_cocci.show_binding_in_out
236 Ast_cocci.CocciRule
(nm
, (deps
, drops
, exists
), x
, _
) -> nm
237 | _
-> i_to_s rulenb
in
238 Common.pr_xxxxxxxxxxxxxxxxx
();
240 Common.pr_xxxxxxxxxxxxxxxxx
()
243 let show_or_not_scr_rule_name rulenb
=
244 if !Flag_cocci.show_ctl_text
or !Flag.show_trying
or
245 !Flag_cocci.show_transinfo
or !Flag_cocci.show_binding_in_out
248 let name = i_to_s rulenb
in
249 Common.pr_xxxxxxxxxxxxxxxxx
();
250 pr
("script rule " ^
name ^
" = ");
251 Common.pr_xxxxxxxxxxxxxxxxx
()
254 let show_or_not_ctl_text2 ctl ast rulenb
=
255 if !Flag_cocci.show_ctl_text
then begin
257 adjust_pp_with_indent
(fun () ->
258 Format.force_newline
();
259 Pretty_print_cocci.print_plus_flag
:= true;
260 Pretty_print_cocci.print_minus_flag
:= true;
261 Pretty_print_cocci.unparse ast
;
266 adjust_pp_with_indent
(fun () ->
267 Format.force_newline
();
268 Pretty_print_engine.pp_ctlcocci
269 !Flag_cocci.show_mcodekind_in_ctl
!Flag_cocci.inline_let_ctl ctl
;
273 let show_or_not_ctl_text a b c
=
274 Common.profile_code
"show_xxx" (fun () -> show_or_not_ctl_text2 a b c
)
278 (* running information *)
279 let get_celem celem
: string =
281 Ast_c.Definition
({Ast_c.f_name
= funcs
;},_
) -> funcs
283 (Ast_c.DeclList
([{Ast_c.v_namei
= Some
((s
, _
),_
);}, _
], _
)) -> s
286 let show_or_not_celem2 prelude celem
=
289 | Ast_c.Definition
({Ast_c.f_name
= funcs
;},_
) ->
290 Flag.current_element
:= funcs
;
291 (" function: ",funcs
)
293 (Ast_c.DeclList
([{Ast_c.v_namei
= Some
((s
, _
),_
);}, _
], _
)) ->
294 Flag.current_element
:= s
;
297 Flag.current_element
:= "something_else";
298 (" ","something else");
300 if !Flag.show_trying
then pr2
(prelude ^ tag ^ trying
)
302 let show_or_not_celem a b
=
303 Common.profile_code
"show_xxx" (fun () -> show_or_not_celem2 a b
)
306 let show_or_not_trans_info2 trans_info
=
307 if !Flag_cocci.show_transinfo
then begin
308 if null trans_info
then pr2
"transformation info is empty"
310 pr2
"transformation info returned:";
312 List.sort
(function (i1
,_
,_
) -> function (i2
,_
,_
) -> compare i1 i2
)
316 trans_info +> List.iter
(fun (i
, subst
, re
) ->
317 pr2
("transform state: " ^
(Common.i_to_s i
));
319 adjust_pp_with_indent_and_header
"with rule_elem: " (fun () ->
320 Pretty_print_cocci.print_plus_flag
:= true;
321 Pretty_print_cocci.print_minus_flag
:= true;
322 Pretty_print_cocci.rule_elem
"" re
;
324 adjust_pp_with_indent_and_header
"with binding: " (fun () ->
325 Pretty_print_engine.pp_binding subst
;
332 let show_or_not_trans_info a
=
333 Common.profile_code
"show_xxx" (fun () -> show_or_not_trans_info2 a
)
337 let show_or_not_binding2 s binding
=
338 if !Flag_cocci.show_binding_in_out
then begin
339 adjust_pp_with_indent_and_header
("binding " ^ s ^
" = ") (fun () ->
340 Pretty_print_engine.pp_binding binding
343 let show_or_not_binding a b
=
344 Common.profile_code
"show_xxx" (fun () -> show_or_not_binding2 a b
)
348 (*****************************************************************************)
349 (* Some helper functions *)
350 (*****************************************************************************)
352 let worth_trying cfiles tokens
=
353 (* drop the following line for a list of list by rules. since we don't
354 allow multiple minirules, all the tokens within a rule should be in
355 a single CFG entity *)
356 let tokens = Common.union_all
tokens in
357 if not
!Flag_cocci.windows
&& not
(null
tokens)
359 (* could also modify the code in get_constants.ml *)
360 let tokens = tokens +> List.map
(fun s
->
362 | _
when s
=~
"^[A-Za-z_][A-Za-z_0-9]*$" ->
365 | _
when s
=~
"^[A-Za-z_]" ->
368 | _
when s
=~
".*[A-Za-z_]$" ->
373 let com = sprintf
"egrep -q '(%s)' %s" (join
"|" tokens) (join
" " cfiles
)
375 (match Sys.command
com with
376 | 0 (* success *) -> true
379 then Printf.printf
"grep failed: %s\n" com);
380 false (* no match, so not worth trying *)
384 let check_macro_in_sp_and_adjust tokens =
385 let tokens = Common.union_all
tokens in
386 tokens +> List.iter
(fun s
->
387 if Hashtbl.mem
!Parsing_hacks._defs s
389 pr2
"warning: macro in semantic patch was in macro definitions";
390 pr2
("disabling macro expansion for " ^ s
);
391 Hashtbl.remove
!Parsing_hacks._defs s
396 let contain_loop gopt
=
399 g#nodes#tolist
+> List.exists
(fun (xi
, node
) ->
400 Control_flow_c.extract_is_loop node
402 | None
-> true (* means nothing, if no g then will not model check *)
406 let sp_contain_typed_metavar_z toplevel_list_list
=
407 let bind x y
= x
or y
in
408 let option_default = false in
409 let mcode _ _
= option_default in
410 let donothing r k e
= k e
in
412 let expression r k e
=
413 match Ast_cocci.unwrap e
with
414 | Ast_cocci.MetaExpr
(_
,_
,_
,Some t
,_
,_
) -> true
415 | Ast_cocci.MetaExpr
(_
,_
,_
,_
,Ast_cocci.LocalID
,_
) -> true
420 Visitor_ast.combiner bind option_default
421 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
423 donothing donothing donothing donothing
424 donothing expression donothing donothing donothing donothing donothing
425 donothing donothing donothing donothing donothing
427 toplevel_list_list
+>
429 (function (nm
,_
,rule
) ->
430 (List.exists
combiner.Visitor_ast.combiner_top_level rule
))
433 let sp_contain_typed_metavar rules
=
434 sp_contain_typed_metavar_z
438 Ast_cocci.CocciRule
(a
,b
,c
,d
) -> (a
,b
,c
)
439 | _
-> failwith
"error in filter")
442 match x
with Ast_cocci.CocciRule _
-> true | _
-> false)
447 (* finding among the #include the one that we need to parse
448 * because they may contain useful type definition or because
449 * we may have to modify them
451 * For the moment we base in part our heuristic on the name of the file, e.g.
452 * serio.c is related we think to #include <linux/serio.h>
455 let (includes_to_parse
: (Common.filename
* Parse_c.program2
) list
-> 'a
) = fun xs ->
456 if !Flag_cocci.no_includes
459 xs +> List.map
(fun (file
, cs
) ->
460 let dir = Common.dirname file
in
462 cs
+> Common.map_filter
(fun (c
,_info_item
) ->
464 | Ast_c.CppTop
(Ast_c.Include
{Ast_c.i_include
= ((x
,ii
));
465 i_rel_pos
= info_h_pos
;}) ->
468 let f = Filename.concat
dir (Common.join
"/" xs) in
469 (* for our tests, all the files are flat in the current dir *)
470 if not
(Sys.file_exists
f) && !Flag_cocci.relax_include_path
472 let attempt2 = Filename.concat
dir (Common.last
xs) in
473 if not
(Sys.file_exists
f) && !Flag_cocci.all_includes
474 then Some
(Filename.concat
!Flag_cocci.include_path
475 (Common.join
"/" xs))
479 | Ast_c.NonLocal
xs ->
480 if !Flag_cocci.all_includes
||
481 Common.fileprefix
(Common.last
xs) = Common.fileprefix file
483 Some
(Filename.concat
!Flag_cocci.include_path
484 (Common.join
"/" xs))
486 | Ast_c.Wierd _
-> None
494 let rec interpret_dependencies local global
= function
495 Ast_cocci.Dep s
-> List.mem s local
496 | Ast_cocci.AntiDep s
->
497 (if !Flag_ctl.steps
!= None
498 then failwith
"steps and ! dependency incompatible");
499 not
(List.mem s local
)
500 | Ast_cocci.EverDep s
-> List.mem s global
501 | Ast_cocci.NeverDep s
->
502 (if !Flag_ctl.steps
!= None
503 then failwith
"steps and ! dependency incompatible");
504 not
(List.mem s global
)
505 | Ast_cocci.AndDep
(s1
,s2
) ->
506 (interpret_dependencies local global s1
) &&
507 (interpret_dependencies local global s2
)
508 | Ast_cocci.OrDep
(s1
,s2
) ->
509 (interpret_dependencies local global s1
) or
510 (interpret_dependencies local global s2
)
511 | Ast_cocci.NoDep
-> true
513 let rec print_dependencies str local global dep
=
514 if !Flag_cocci.show_dependencies
519 let rec loop = function
520 Ast_cocci.Dep s
| Ast_cocci.AntiDep s
->
521 if not
(List.mem s
!seen)
525 then pr2
(s^
" satisfied")
526 else pr2
(s^
" not satisfied");
529 | Ast_cocci.EverDep s
| Ast_cocci.NeverDep s
->
530 if not
(List.mem s
!seen)
534 then pr2
(s^
" satisfied")
535 else pr2
(s^
" not satisfied");
538 | Ast_cocci.AndDep
(s1
,s2
) ->
541 | Ast_cocci.OrDep
(s1
,s2
) ->
544 | Ast_cocci.NoDep
-> () in
550 (* --------------------------------------------------------------------- *)
551 (* #include relative position in the file *)
552 (* --------------------------------------------------------------------- *)
554 (* compute the set of new prefixes
556 * "a/b/x"; (* in fact it is now a list of string so ["a";"b";"x"] *)
560 * it would give
for the first element
561 * ""; "a"; "a/b"; "a/b/x"
565 * update
: if the
include is inside a ifdef a put nothing
. cf
-test incl
.
566 * this is because we dont want code added inside ifdef
.
569 let compute_new_prefixes xs =
570 xs +> Common.map_withenv
(fun already
xs ->
571 let subdirs_prefixes = Common.inits
xs in
572 let new_first = subdirs_prefixes +> List.filter
(fun x
->
573 not
(List.mem x already
)
582 (* does via side effect on the ref in the Include in Ast_c *)
583 let rec update_include_rel_pos cs
=
584 let only_include = cs
+> Common.map_filter
(fun c
->
586 | Ast_c.CppTop
(Ast_c.Include
{Ast_c.i_include
= ((x
,_
));
588 i_is_in_ifdef
= inifdef
}) ->
590 | Ast_c.Wierd _
-> None
599 let (locals
, nonlocals
) =
600 only_include +> Common.partition_either
(fun (c
, aref
) ->
602 | Ast_c.Local x
-> Left
(x
, aref
)
603 | Ast_c.NonLocal x
-> Right
(x
, aref
)
604 | Ast_c.Wierd x
-> raise Impossible
607 update_rel_pos_bis locals
;
608 update_rel_pos_bis nonlocals
;
610 and update_rel_pos_bis
xs =
611 let xs'
= List.map fst
xs in
612 let the_first = compute_new_prefixes xs'
in
613 let the_last = List.rev
(compute_new_prefixes (List.rev
xs'
)) in
614 let merged = Common.zip
xs (Common.zip
the_first the_last) in
615 merged +> List.iter
(fun ((x
, aref
), (the_first, the_last)) ->
618 Ast_c.first_of
= the_first;
619 Ast_c.last_of
= the_last;
628 (*****************************************************************************)
629 (* All the information needed around the C elements and Cocci rules *)
630 (*****************************************************************************)
632 type toplevel_c_info
= {
633 ast_c
: Ast_c.toplevel
; (* contain refs so can be modified *)
634 tokens_c
: Parser_c.token list
;
637 flow
: Control_flow_c.cflow
option; (* it's the "fixed" flow *)
640 env_typing_before
: TAC.environment
;
641 env_typing_after
: TAC.environment
;
643 was_modified
: bool ref;
648 type toplevel_cocci_info_script_rule
= {
649 scr_ast_rule
: string * (string * (string * string)) list
* string;
651 scr_dependencies
: Ast_cocci.dependency
;
656 type toplevel_cocci_info_cocci_rule
= {
657 ctl
: Lib_engine.ctlcocci
* (CCI.pred list list
);
658 ast_rule
: Ast_cocci.rule
;
659 isexp
: bool; (* true if + code is an exp, only for Flag.make_hrule *)
662 dependencies
: Ast_cocci.dependency
;
663 (* There are also some hardcoded rule names in parse_cocci.ml:
664 * let reserved_names = ["all";"optional_storage";"optional_qualifier"]
666 dropped_isos
: string list
;
667 free_vars
: Ast_cocci.meta_name list
;
668 negated_pos_vars
: Ast_cocci.meta_name list
;
669 used_after
: Ast_cocci.meta_name list
;
670 positions
: Ast_cocci.meta_name list
;
674 was_matched
: bool ref;
677 type toplevel_cocci_info
=
678 ScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
679 | CocciRuleCocciInfo
of toplevel_cocci_info_cocci_rule
681 type kind_file
= Header
| Source
685 was_modified_once
: bool ref;
686 asts
: toplevel_c_info list
;
691 let g_contain_typedmetavar = ref false
694 let last_env_toplevel_c_info xs =
695 (Common.last
xs).env_typing_after
697 let concat_headers_and_c (ccs
: file_info list
)
698 : (toplevel_c_info
* string) list
=
699 (List.concat
(ccs
+> List.map
(fun x
->
700 x
.asts
+> List.map
(fun x'
->
703 let for_unparser xs =
704 xs +> List.map
(fun x
->
705 (x
.ast_c
, (x
.fullstring
, x
.tokens_c
)), Unparse_c.PPviastr
708 let gen_pdf_graph () =
709 (Ctl_engine.get_graph_files
()) +> List.iter
(fun outfile
->
710 Printf.printf
"Generation of %s%!" outfile
;
711 let filename_stack = Ctl_engine.get_graph_comp_files outfile
in
712 List.iter
(fun filename
->
713 ignore
(Unix.system
("dot " ^ filename ^
" -Tpdf -o " ^ filename ^
".pdf;"))
715 let (head
,tail
) = (List.hd
filename_stack, List.tl
filename_stack) in
716 ignore
(Unix.system
("cp " ^ head ^
".pdf " ^ outfile ^
".pdf;"));
717 tail
+> List.iter
(fun filename
->
718 ignore
(Unix.system
("mv " ^ outfile ^
".pdf /tmp/tmp.pdf;"));
719 ignore
(Unix.system
("pdftk " ^ filename ^
".pdf /tmp/tmp.pdf cat output " ^ outfile ^
".pdf"));
721 ignore
(Unix.system
("rm /tmp/tmp.pdf;"));
722 List.iter
(fun filename
->
723 ignore
(Unix.system
("rm " ^ filename ^
" " ^ filename ^
".pdf;"))
725 Printf.printf
" - Done\n")
728 (* --------------------------------------------------------------------- *)
729 let prepare_cocci ctls free_var_lists negated_pos_lists
730 used_after_lists positions_list astcocci
=
732 let gathered = Common.index_list_1
733 (zip
(zip
(zip
(zip
(zip ctls astcocci
) free_var_lists
)
734 negated_pos_lists
) used_after_lists
) positions_list
)
737 (fun ((((((ctl_toplevel_list
,ast
),free_var_list
),negated_pos_list
),
739 positions_list
),rulenb
) ->
741 let is_script_rule r
=
742 match r
with Ast_cocci.ScriptRule _
-> true | _
-> false in
744 if not
(List.length ctl_toplevel_list
= 1) && not
(is_script_rule ast
)
745 then failwith
"not handling multiple minirules";
748 Ast_cocci.ScriptRule
(lang
,deps
,mv
,code
) ->
751 scr_ast_rule
= (lang
, mv
, code
);
753 scr_dependencies
= deps
;
757 in ScriptRuleCocciInfo
r
758 | Ast_cocci.CocciRule
759 (rulename
,(dependencies
,dropped_isos
,z
),restast
,isexp
) ->
762 ctl
= List.hd ctl_toplevel_list
;
764 isexp
= List.hd isexp
;
766 dependencies
= dependencies
;
767 dropped_isos
= dropped_isos
;
768 free_vars
= List.hd free_var_list
;
769 negated_pos_vars
= List.hd negated_pos_list
;
770 used_after
= List.hd used_after_list
;
771 positions
= List.hd positions_list
;
773 was_matched
= ref false;
778 (* --------------------------------------------------------------------- *)
780 let build_info_program cprogram env
=
781 let (cs
, parseinfos
) = Common.unzip cprogram
in
783 Common.unzip
(TAC.annotate_program env
!g_contain_typedmetavar cs
) in
785 zip
(zip cs parseinfos
) envs
+> List.map
(fun ((c
, parseinfo
), (enva
,envb
))->
786 let (fullstr
, tokens) = parseinfo
in
789 ast_to_flow_with_error_messages c
+> Common.map_option
(fun flow ->
790 let flow = Ast_to_flow.annotate_loop_nodes
flow in
792 (* remove the fake nodes for julia *)
793 let fixed_flow = CCI.fix_flow_ctl
flow in
795 if !Flag_cocci.show_flow
then print_flow fixed_flow;
796 if !Flag_cocci.show_before_fixed_flow
then print_flow flow;
803 ast_c
= c
; (* contain refs so can be modified *)
805 fullstring
= fullstr
;
809 contain_loop = contain_loop flow;
811 env_typing_before
= enva
;
812 env_typing_after
= envb
;
814 was_modified
= ref false;
820 (* Optimisation. Try not unparse/reparse the whole file when have modifs *)
821 let rebuild_info_program cs file isexp
=
822 cs
+> List.map
(fun c
->
825 (match !Flag.make_hrule
with
827 Unparse_hrule.pp_program
(c
.ast_c
, (c
.fullstring
, c
.tokens_c
))
831 let file = Common.new_temp_file
"cocci_small_output" ".c" in
833 [(c
.ast_c
, (c
.fullstring
, c
.tokens_c
)), Unparse_c.PPnormal
]
836 (* Common.command2 ("cat " ^ file); *)
837 let cprogram = cprogram_of_file file in
838 let xs = build_info_program cprogram c
.env_typing_before
in
840 (* TODO: assert env has not changed,
841 * if yes then must also reparse what follows even if not modified.
842 * Do that only if contain_typedmetavar of course, so good opti.
844 (* Common.list_init xs *) (* get rid of the FinalDef *)
850 let rebuild_info_c_and_headers ccs isexp
=
851 ccs
+> List.iter
(fun c_or_h
->
852 if c_or_h
.asts
+> List.exists
(fun c
-> !(c
.was_modified
))
853 then c_or_h
.was_modified_once
:= true;
855 ccs
+> List.map
(fun c_or_h
->
857 asts
= rebuild_info_program c_or_h
.asts c_or_h
.full_fname isexp
}
866 let prepare_c files
: file_info list
=
867 let cprograms = List.map
cprogram_of_file_cached files
in
868 let includes = includes_to_parse
(zip files
cprograms) in
870 (* todo?: may not be good to first have all the headers and then all the c *)
872 (includes +> List.map
(fun hpath
-> Right hpath
))
874 ((zip files
cprograms) +> List.map
(fun (file, asts
) -> Left
(file, asts
)))
877 let env = ref TAC.initial_env
in
879 let ccs = all +> Common.map_filter
(fun x
->
882 if not
(Common.lfile_exists hpath
)
884 pr2
("TYPE: header " ^ hpath ^
" not found");
888 let h_cs = cprogram_of_file_cached hpath
in
889 let info_h_cs = build_info_program h_cs !env in
893 else last_env_toplevel_c_info info_h_cs
896 fname
= Common.basename hpath
;
899 was_modified_once
= ref false;
903 | Left
(file, cprogram) ->
904 (* todo?: don't update env ? *)
905 let cs = build_info_program cprogram !env in
906 (* we do that only for the c, not for the h *)
907 ignore
(update_include_rel_pos (cs +> List.map
(fun x
-> x
.ast_c
)));
909 fname
= Common.basename
file;
912 was_modified_once
= ref false;
921 (*****************************************************************************)
922 (* Processing the ctls and toplevel C elements *)
923 (*****************************************************************************)
925 (* The main algorithm =~
926 * The algorithm is roughly:
927 * for_all ctl rules in SP
928 * for_all minirule in rule (no more)
929 * for_all binding (computed during previous phase)
931 * match control flow of function vs minirule
932 * with the binding and update the set of possible
933 * bindings, and returned the possibly modified function.
934 * pretty print modified C elements and reparse it.
937 * On ne prends que les newbinding ou returned_any_state est vrai.
938 * Si ca ne donne rien, on prends ce qu'il y avait au depart.
939 * Mais au nouveau depart de quoi ?
940 * - si ca donne rien apres avoir traité toutes les fonctions avec ce binding ?
941 * - ou alors si ca donne rien, apres avoir traité toutes les fonctions
942 * avec tous les bindings du round d'avant ?
944 * Julia pense qu'il faut prendre la premiere solution.
945 * Example: on a deux environnements candidats, E1 et E2 apres avoir traité
946 * la regle ctl 1. On arrive sur la regle ctl 2.
947 * E1 ne donne rien pour la regle 2, on garde quand meme E1 pour la regle 3.
948 * E2 donne un match a un endroit et rend E2' alors on utilise ca pour
951 * I have not to look at used_after_list to decide to restart from
952 * scratch. I just need to look if the binding list is empty.
953 * Indeed, let's suppose that a SP have 3 regions/rules. If we
954 * don't find a match for the first region, then if this first
955 * region does not bind metavariable used after, that is if
956 * used_after_list is empty, then mysat(), even if does not find a
957 * match, will return a Left, with an empty transformation_info,
958 * and so current_binding will grow. On the contrary if the first
959 * region must bind some metavariables used after, and that we
960 * dont find any such region, then mysat() will returns lots of
961 * Right, and current_binding will not grow, and so we will have
962 * an empty list of binding, and we will catch such a case.
964 * opti: julia says that because the binding is
965 * determined by the used_after_list, the items in the list
966 * are kind of sorted, so could optimise the insert_set operations.
970 (* r(ule), c(element in C code), e(nvironment) *)
972 let rec apply_python_rule r cache newes e rules_that_have_matched
973 rules_that_have_ever_matched
=
974 show_or_not_scr_rule_name r.scr_ruleid
;
975 if not
(interpret_dependencies rules_that_have_matched
976 !rules_that_have_ever_matched
r.scr_dependencies
)
979 print_dependencies "dependencies for script not satisfied:"
980 rules_that_have_matched
981 !rules_that_have_ever_matched
r.scr_dependencies
;
982 show_or_not_binding "in environment" e
;
983 (cache
, (e
, rules_that_have_matched
)::newes
)
987 let (_
, mv
, _
) = r.scr_ast_rule
in
988 if List.for_all
(Pycocci.contains_binding e
) mv
991 let relevant_bindings =
993 (function ((re
,rm
),_
) ->
994 List.exists
(function (_
,(r,m
)) -> r = re
&& m
= rm
) mv
)
997 if List.mem
relevant_bindings cache
1001 print_dependencies "dependencies for script satisfied:"
1002 rules_that_have_matched
1003 !rules_that_have_ever_matched
r.scr_dependencies
;
1004 show_or_not_binding "in" e
;
1005 Pycocci.build_classes
(List.map
(function (x
,y
) -> x
) e
);
1006 Pycocci.construct_variables mv e
;
1007 let _ = Pycocci.pyrun_simplestring
1008 ("import coccinelle\nfrom coccinelle "^
1009 "import *\ncocci = Cocci()\n" ^
1011 relevant_bindings :: cache
1013 if !Pycocci.inc_match
1014 then (new_cache, merge_env
[(e
, rules_that_have_matched
)] newes
)
1015 else (new_cache, newes
)
1017 else (cache
, merge_env
[(e
, rules_that_have_matched
)] newes
)
1020 and apply_cocci_rule
r rules_that_have_ever_matched es
(ccs:file_info list
ref) =
1021 Common.profile_code
r.rulename
(fun () ->
1022 show_or_not_rule_name r.ast_rule
r.ruleid
;
1023 show_or_not_ctl_text r.ctl
r.ast_rule
r.ruleid
;
1025 let reorganized_env =
1026 reassociate_positions
r.free_vars
r.negated_pos_vars
!es
in
1028 (* looping over the environments *)
1029 let (_,newes
(* envs for next round/rule *)) =
1031 (function (cache
,newes
) ->
1032 function ((e
,rules_that_have_matched
),relevant_bindings) ->
1033 if not
(interpret_dependencies rules_that_have_matched
1034 !rules_that_have_ever_matched
r.dependencies
)
1038 ("dependencies for rule "^
r.rulename^
" not satisfied:")
1039 rules_that_have_matched
1040 !rules_that_have_ever_matched
r.dependencies
;
1041 show_or_not_binding "in environment" e
;
1044 [(e
+> List.filter
(fun (s
,v
) -> List.mem s
r.used_after
),
1045 rules_that_have_matched
)]
1050 try List.assoc
relevant_bindings cache
1054 ("dependencies for rule "^
r.rulename^
" satisfied:")
1055 rules_that_have_matched
1056 !rules_that_have_ever_matched
r.dependencies
;
1057 show_or_not_binding "in" e
;
1058 show_or_not_binding "relevant in" relevant_bindings;
1060 let children_e = ref [] in
1062 (* looping over the functions and toplevel elements in
1064 concat_headers_and_c !ccs +> List.iter
(fun (c
,f) ->
1067 (* does also some side effects on c and r *)
1069 process_a_ctl_a_env_a_toplevel
r relevant_bindings
1071 match processed with
1073 | Some newbindings
->
1074 newbindings
+> List.iter
(fun newbinding
->
1076 Common.insert_set newbinding
!children_e)
1077 ); (* end iter cs *)
1080 let old_bindings_to_keep =
1082 (e
+> List.filter
(fun (s
,v
) -> List.mem s
r.used_after
)) in
1084 if null
new_bindings
1087 (*use the old bindings, specialized to the used_after_list*)
1088 if !Flag_ctl.partial_match
1091 "Empty list of bindings, I will restart from old env";
1092 [(old_bindings_to_keep,rules_that_have_matched
)]
1095 (* combine the new bindings with the old ones, and
1096 specialize to the used_after_list *)
1097 let old_variables = List.map fst
old_bindings_to_keep in
1098 (* have to explicitly discard the inherited variables
1099 because we want the inherited value of the positions
1100 variables not the extended one created by
1101 reassociate_positions. want to reassociate freshly
1102 according to the free variables of each rule. *)
1103 let new_bindings_to_add =
1109 List.mem s
r.used_after
&&
1110 not
(List.mem s
old_variables)))) in
1112 (function new_binding_to_add
->
1115 old_bindings_to_keep new_binding_to_add
),
1116 r.rulename
::rules_that_have_matched
))
1117 new_bindings_to_add in
1118 ((relevant_bindings,new_bindings)::cache
,
1119 merge_env
new_e newes
))
1120 ([],[]) reorganized_env in (* end iter es *)
1122 then Common.push2
r.rulename rules_that_have_ever_matched
;
1126 (* apply the tagged modifs and reparse *)
1127 if not
!Flag.sgrep_mode2
1128 then ccs := rebuild_info_c_and_headers !ccs r.isexp
1131 and merge_env
new_e old_e
=
1134 function (e
,rules
) as elem
->
1135 let (same
,diff
) = List.partition
(function (e1
,_) -> e
= e1
) old_e
in
1138 | [(_,old_rules
)] -> (e
,Common.union_set rules old_rules
) :: diff
1139 | _ -> failwith
"duplicate environment entries")
1142 and bigloop2 rs
(ccs: file_info list
) =
1143 let es = ref [(Ast_c.emptyMetavarsBinding
,[])] in
1144 let ccs = ref ccs in
1145 let rules_that_have_ever_matched = ref [] in
1147 (* looping over the rules *)
1148 rs
+> List.iter
(fun r ->
1150 ScriptRuleCocciInfo
r ->
1151 if !Flag_cocci.show_ctl_text
then begin
1152 Common.pr_xxxxxxxxxxxxxxxxx
();
1153 pr
("script: " ^
r.language
);
1154 Common.pr_xxxxxxxxxxxxxxxxx
();
1156 adjust_pp_with_indent
(fun () ->
1157 Format.force_newline
();
1158 let (l
,mv
,code
) = r.scr_ast_rule
in
1159 let deps = r.scr_dependencies
in
1160 Pretty_print_cocci.unparse
1161 (Ast_cocci.ScriptRule
(l
,deps,mv
,code
)));
1164 if !Flag.show_misc
then print_endline
"RESULT =";
1168 (function (cache
, newes
) ->
1169 function (e
, rules_that_have_matched
) ->
1170 match r.language
with
1172 apply_python_rule r cache newes e rules_that_have_matched
1173 rules_that_have_ever_matched
1175 concat_headers_and_c !ccs +> List.iter
(fun (c
,_) ->
1178 Printf.printf
"Flow: %s\r\nFlow!\r\n%!" c
.fullstring
);
1181 Printf.printf
"Unknown language: %s\n" r.language
;
1187 | CocciRuleCocciInfo
r ->
1188 apply_cocci_rule
r rules_that_have_ever_matched es ccs);
1190 if !Flag.sgrep_mode2
1192 (* sgrep can lead to code that is not parsable, but we must
1193 * still call rebuild_info_c_and_headers to pretty print the
1194 * action (MINUS), so that later the diff will show what was
1195 * matched by sgrep. But we don't want the parsing error message
1196 * hence the following flag setting. So this code propably
1197 * will generate a NotParsedCorrectly for the matched parts
1198 * and the very final pretty print and diff will work
1200 Flag_parsing_c.verbose_parsing
:= false;
1201 ccs := rebuild_info_c_and_headers !ccs false
1203 !ccs (* return final C asts *)
1205 and reassociate_positions free_vars negated_pos_vars envs
=
1206 (* issues: isolate the bindings that are relevant to a given rule.
1207 separate out the position variables
1208 associate all of the position variables for a given set of relevant
1209 normal variable bindings with each set of relevant normal variable
1210 bindings. Goal: if eg if@p (E) matches in two places, then both inherited
1211 occurrences of E should see both bindings of p, not just its own.
1212 Otherwise, a position constraint for something that matches in two
1213 places will never be useful, because the position can always be
1214 different from the other one. *)
1218 List.filter
(function (x
,_) -> List.mem x free_vars
) e
)
1220 let splitted_relevant =
1221 (* separate the relevant variables into the non-position ones and the
1226 (function (non_pos
,pos
) ->
1227 function (v
,_) as x
->
1228 if List.mem v negated_pos_vars
1229 then (non_pos
,x
::pos
)
1230 else (x
::non_pos
,pos
))
1233 let splitted_relevant =
1235 (function (non_pos
,pos
) ->
1236 (List.sort compare non_pos
,List.sort compare pos
))
1237 splitted_relevant in
1240 (function non_pos
->
1242 if List.mem np non_pos
then non_pos
else np
::non_pos
)
1243 [] splitted_relevant in
1244 let extended_relevant =
1245 (* extend the position variables with the values found at other identical
1246 variable bindings *)
1248 (function non_pos
->
1251 (function (other_non_pos
,other_pos
) ->
1252 (* do we want equal? or just somehow compatible? eg non_pos
1253 binds only E, but other_non_pos binds both E and E1 *)
1254 non_pos
= other_non_pos
)
1255 splitted_relevant in
1259 (combine_pos negated_pos_vars
1260 (List.map
(function (_,x
) -> x
) others)))))
1263 (List.map
(function (non_pos
,_) -> List.assoc non_pos
extended_relevant)
1266 and combine_pos negated_pos_vars
others =
1270 Ast_c.MetaPosValList
1273 (function positions
->
1274 function other_list
->
1276 match List.assoc posvar other_list
with
1277 Ast_c.MetaPosValList l1
->
1278 Common.union_set l1 positions
1279 | _ -> failwith
"bad value for a position variable"
1280 with Not_found
-> positions
)
1285 Common.profile_code
"bigloop" (fun () -> bigloop2 a b
)
1291 (* does side effects on C ast and on Cocci info rule *)
1292 and process_a_ctl_a_env_a_toplevel2
r e c
f =
1293 indent_do
(fun () ->
1294 show_or_not_celem "trying" c
.ast_c
;
1295 Flag.currentfile
:= Some
(f ^
":" ^
get_celem c
.ast_c
);
1296 let (trans_info, returned_any_states
, inherited_bindings
, newbindings
) =
1297 Common.save_excursion
Flag_ctl.loop_in_src_code
(fun () ->
1298 Flag_ctl.loop_in_src_code
:= !Flag_ctl.loop_in_src_code
||c
.contain_loop;
1300 (***************************************)
1301 (* !Main point! The call to the engine *)
1302 (***************************************)
1303 let model_ctl = CCI.model_for_ctl
r.dropped_isos
(Common.some c
.flow) e
1304 in CCI.mysat
model_ctl r.ctl
(r.used_after
, e
)
1307 if not returned_any_states
1310 show_or_not_celem "found match in" c
.ast_c
;
1311 show_or_not_trans_info trans_info;
1312 List.iter
(show_or_not_binding "out") newbindings
;
1314 r.was_matched
:= true;
1316 if not
(null
trans_info)
1318 c
.was_modified
:= true;
1320 (* les "more than one var in a decl" et "already tagged token"
1321 * font crasher coccinelle. Si on a 5 fichiers, donc on a 5
1322 * failed. Le try limite le scope des crashes pendant la
1323 * trasformation au fichier concerne. *)
1325 (* modify ast via side effect *)
1326 ignore
(Transformation_c.transform
r.rulename
r.dropped_isos
1327 inherited_bindings
trans_info (Common.some c
.flow));
1328 with Timeout
-> raise Timeout
| UnixExit i
-> raise
(UnixExit i
)
1331 Some
(List.map
(function x
-> x
@inherited_bindings
) newbindings
)
1335 and process_a_ctl_a_env_a_toplevel a b c
f=
1336 Common.profile_code
"process_a_ctl_a_env_a_toplevel"
1337 (fun () -> process_a_ctl_a_env_a_toplevel2 a b c
f)
1341 (*****************************************************************************)
1342 (* The main function *)
1343 (*****************************************************************************)
1345 let full_engine2 (coccifile
, isofile
) cfiles
=
1347 show_or_not_cfiles cfiles
;
1348 show_or_not_cocci coccifile isofile
;
1349 Pycocci.set_coccifile coccifile
;
1352 if not
(Common.lfile_exists
isofile)
1354 pr2
("warning: Can't find default iso file: " ^
isofile);
1360 (* useful opti when use -dir *)
1361 let (astcocci
,free_var_lists
,negated_pos_lists
,used_after_lists
,
1362 positions_lists
,toks
,_) =
1363 sp_of_file coccifile
isofile
1366 Common.memoized
_hctl (coccifile
, isofile) (fun () ->
1367 ctls_of_ast astcocci used_after_lists positions_lists
)
1370 let contain_typedmetavar = sp_contain_typed_metavar astcocci
in
1372 (* optimisation allowing to launch coccinelle on all the drivers *)
1373 if !Flag_cocci.worth_trying_opt
&& not
(worth_trying cfiles toks
)
1375 pr2
("not worth trying:" ^
Common.join
" " cfiles
);
1376 cfiles
+> List.map
(fun s
-> s
, None
)
1380 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1381 if !Flag.show_misc
then pr
"let's go";
1382 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1384 g_contain_typedmetavar := contain_typedmetavar;
1386 check_macro_in_sp_and_adjust toks
;
1389 prepare_cocci ctls free_var_lists negated_pos_lists
1390 used_after_lists positions_lists astcocci
in
1391 let c_infos = prepare_c cfiles
in
1393 show_or_not_ctl_tex astcocci
ctls;
1395 (* ! the big loop ! *)
1396 let c_infos'
= bigloop
cocci_infos c_infos in
1398 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1399 if !Flag.show_misc
then pr
"Finished";
1400 if !Flag_ctl.graphical_trace
then gen_pdf_graph ();
1401 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1403 c_infos'
+> List.map
(fun c_or_h
->
1404 if !(c_or_h
.was_modified_once
)
1406 let outfile = Common.new_temp_file
"cocci-output" ("-" ^ c_or_h
.fname
)
1409 if c_or_h
.fkind
= Header
1410 then pr2
("a header file was modified: " ^ c_or_h
.fname
);
1412 (* and now unparse everything *)
1413 cfile_of_program (for_unparser c_or_h
.asts
) outfile;
1415 let show_only_minus = !Flag.sgrep_mode2
in
1416 show_or_not_diff c_or_h
.fpath
outfile show_only_minus;
1419 if !Flag.sgrep_mode2
then None
else Some
outfile
1423 (c_or_h
.fpath
, None
)
1427 let full_engine a b
=
1428 Common.profile_code
"full_engine" (fun () -> full_engine2 a b
)
1431 (*****************************************************************************)
1432 (* check duplicate from result of full_engine *)
1433 (*****************************************************************************)
1435 let check_duplicate_modif2 xs =
1436 (* opti: let groups = Common.groupBy (fun (a,resa) (b,resb) -> a =$= b) xs *)
1437 pr2
("Check duplication for " ^ i_to_s
(List.length
xs) ^
" files");
1438 let groups = Common.group_assoc_bykey_eff
xs in
1439 groups +> Common.map_filter
(fun (file, xs) ->
1441 | [] -> raise Impossible
1442 | [res] -> Some
(file, res)
1446 if not
(List.for_all
(fun res2
-> res2
= None
) xs)
1448 pr2
("different modification result for " ^
file);
1451 else Some
(file, None
)
1453 if not
(List.for_all
(fun res2
->
1457 let diff = Common.cmd_to_list
("diff -u -b -B "^
res^
" "^res2
)
1461 pr2
("different modification result for " ^
file);
1464 else Some
(file, Some
res)
1468 let check_duplicate_modif a
=
1469 Common.profile_code
"check_duplicate" (fun () -> check_duplicate_modif2 a
)