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
52 let cfile_of_program program2_with_ppmethod outf
=
53 Unparse_c2.pp_program program2_with_ppmethod outf
55 (* for memoization, contains only one entry, the one for the SP *)
56 let _hparse = Hashtbl.create
101
57 let _hctl = Hashtbl.create
101
59 (* --------------------------------------------------------------------- *)
61 (* --------------------------------------------------------------------- *)
62 let sp_of_file2 file iso
=
63 Common.memoized
_hparse (file
, iso
) (fun () ->
64 Parse_cocci.process file iso
false)
65 let sp_of_file file iso
=
66 Common.profile_code
"parse cocci" (fun () -> sp_of_file2 file iso
)
69 (* --------------------------------------------------------------------- *)
71 (* --------------------------------------------------------------------- *)
73 Ograph_extended.print_ograph_mutable flow
"/tmp/test.dot" true
76 let ast_to_flow_with_error_messages2 x
=
78 try Ast_to_flow.ast_to_control_flow x
79 with Ast_to_flow.Error x
->
80 Ast_to_flow.report_error x
;
83 flowopt +> do_option
(fun flow
->
84 (* This time even if there is a deadcode, we still have a
85 * flow graph, so I can try the transformation and hope the
86 * deadcode will not bother us.
88 try Ast_to_flow.deadcode_detection flow
89 with Ast_to_flow.Error
(Ast_to_flow.DeadCode x
) ->
90 Ast_to_flow.report_error
(Ast_to_flow.DeadCode x
);
93 let ast_to_flow_with_error_messages a
=
94 Common.profile_code
"flow" (fun () -> ast_to_flow_with_error_messages2 a
)
97 (* --------------------------------------------------------------------- *)
99 (* --------------------------------------------------------------------- *)
100 let ctls_of_ast2 ast ua pos
=
102 (function ast
-> function (ua
,pos
) ->
106 else Asttoctl2.asttoctl ast ua pos
)
107 (Asttomember.asttomember ast ua
))
108 ast
(List.combine ua pos
)
110 let ctls_of_ast ast ua
=
111 Common.profile_code
"asttoctl2" (fun () -> ctls_of_ast2 ast ua
)
113 (*****************************************************************************)
114 (* Some debugging functions *)
115 (*****************************************************************************)
119 let show_or_not_cfile2 cfile
=
120 if !Flag_cocci.show_c
then begin
121 Common.pr2_xxxxxxxxxxxxxxxxx
();
122 pr2
("processing C file: " ^ cfile
);
123 Common.pr2_xxxxxxxxxxxxxxxxx
();
124 Common.command2
("cat " ^ cfile
);
126 let show_or_not_cfile a
=
127 Common.profile_code
"show_xxx" (fun () -> show_or_not_cfile2 a
)
129 let show_or_not_cfiles cfiles
= List.iter
show_or_not_cfile cfiles
132 let show_or_not_cocci2 coccifile isofile
=
133 if !Flag_cocci.show_cocci
then begin
134 Common.pr2_xxxxxxxxxxxxxxxxx
();
135 pr2
("processing semantic patch file: " ^ coccifile
);
136 isofile
+> (fun s
-> pr2
("with isos from: " ^ s
));
137 Common.pr2_xxxxxxxxxxxxxxxxx
();
138 Common.command2
("cat " ^ coccifile
);
141 let show_or_not_cocci a b
=
142 Common.profile_code
"show_xxx" (fun () -> show_or_not_cocci2 a b
)
147 let show_or_not_diff2 cfile outfile show_only_minus
=
148 if !Flag_cocci.show_diff
then begin
149 match Common.fst
(Compare_c.compare_default cfile outfile
) with
150 Compare_c.Correct
-> () (* diff only in spacing, etc *)
152 (* may need --strip-trailing-cr under windows *)
156 match !Flag_parsing_c.diff_lines
with
157 | None
-> "diff -u -p " ^ cfile ^
" " ^ outfile
158 | Some n
-> "diff -U "^n^
" -p "^cfile^
" "^outfile
in
160 let res = Common.cmd_to_list
line in
161 match (!Flag.patch
,res) with
162 (* create something that looks like the output of patch *)
163 (Some prefix
,minus_file
::plus_file
::rest
) ->
164 let drop_prefix file
=
168 (match Str.split
(Str.regexp prefix
) file
with
169 [base_file
] -> base_file
170 | _
-> failwith
"prefix not found in the old file name") in
172 match List.rev
(Str.split
(Str.regexp
" ") line) with
173 new_file
::old_file
::cmdrev
->
177 (List.rev
("/tmp/nothing" :: old_file
:: cmdrev
))
179 let old_base_file = drop_prefix old_file
in
182 (("b"^
old_base_file)::("a"^
old_base_file)::cmdrev
))
183 | _
-> failwith
"bad command" in
184 let (minus_line
,plus_line
) =
186 then (minus_file
,plus_file
)
188 match (Str.split
(Str.regexp
"[ \t]") minus_file
,
189 Str.split
(Str.regexp
"[ \t]") plus_file
) with
190 ("---"::old_file
::old_rest
,"+++"::new_file
::new_rest
) ->
191 let old_base_file = drop_prefix old_file
in
193 ("---"::("a"^
old_base_file)::old_rest
),
195 ("+++"::("b"^
old_base_file)::new_rest
))
198 (Printf.sprintf
"bad diff header lines: %s %s"
199 (String.concat
":" l1
) (String.concat
":" l2
)) in
200 diff_line::minus_line
::plus_line
::rest
202 xs +> List.iter
(fun s
->
203 if s
=~
"^\\+" && show_only_minus
207 let show_or_not_diff a b c
=
208 Common.profile_code
"show_xxx" (fun () -> show_or_not_diff2 a b c
)
211 (* the derived input *)
213 let show_or_not_ctl_tex2 astcocci ctls
=
214 if !Flag_cocci.show_ctl_tex
then begin
215 Ctltotex.totex
("/tmp/__cocci_ctl.tex") astcocci ctls
;
216 Common.command2
("cd /tmp; latex __cocci_ctl.tex; " ^
217 "dvips __cocci_ctl.dvi -o __cocci_ctl.ps;" ^
218 "gv __cocci_ctl.ps &");
220 let show_or_not_ctl_tex a b
=
221 Common.profile_code
"show_xxx" (fun () -> show_or_not_ctl_tex2 a b
)
225 let show_or_not_rule_name ast rulenb
=
226 if !Flag_cocci.show_ctl_text
or !Flag.show_trying
or
227 !Flag_cocci.show_transinfo
or !Flag_cocci.show_binding_in_out
232 Ast_cocci.CocciRule
(nm
, (deps
, drops
, exists
), x
, _
) -> nm
233 | _
-> i_to_s rulenb
in
234 Common.pr_xxxxxxxxxxxxxxxxx
();
236 Common.pr_xxxxxxxxxxxxxxxxx
()
239 let show_or_not_scr_rule_name rulenb
=
240 if !Flag_cocci.show_ctl_text
or !Flag.show_trying
or
241 !Flag_cocci.show_transinfo
or !Flag_cocci.show_binding_in_out
244 let name = i_to_s rulenb
in
245 Common.pr_xxxxxxxxxxxxxxxxx
();
246 pr
("script rule " ^
name ^
" = ");
247 Common.pr_xxxxxxxxxxxxxxxxx
()
250 let show_or_not_ctl_text2 ctl ast rulenb
=
251 if !Flag_cocci.show_ctl_text
then begin
253 adjust_pp_with_indent
(fun () ->
254 Format.force_newline
();
255 Pretty_print_cocci.print_plus_flag
:= true;
256 Pretty_print_cocci.print_minus_flag
:= true;
257 Pretty_print_cocci.unparse ast
;
262 adjust_pp_with_indent
(fun () ->
263 Format.force_newline
();
264 Pretty_print_engine.pp_ctlcocci
265 !Flag_cocci.show_mcodekind_in_ctl
!Flag_cocci.inline_let_ctl ctl
;
269 let show_or_not_ctl_text a b c
=
270 Common.profile_code
"show_xxx" (fun () -> show_or_not_ctl_text2 a b c
)
274 (* running information *)
276 let show_or_not_celem2 prelude celem
=
277 if !Flag.show_trying
then
279 | Ast_c.Definition
((funcs
,_
,_
,_c
),_
) ->
280 pr2
(prelude ^
" function: " ^ funcs
);
282 (Ast_c.DeclList
([(Some
((s
, _
),_
), typ
, sto
, _local
), _
], _
)) ->
283 pr2
(prelude ^
" variable " ^ s
);
285 pr2
(prelude ^
" something else");
287 let show_or_not_celem a b
=
288 Common.profile_code
"show_xxx" (fun () -> show_or_not_celem2 a b
)
291 let show_or_not_trans_info2 trans_info
=
292 if !Flag_cocci.show_transinfo
then begin
293 if null trans_info
then pr2
"transformation info is empty"
295 pr2
"transformation info returned:";
297 List.sort
(function (i1
,_
,_
) -> function (i2
,_
,_
) -> compare i1 i2
)
301 trans_info +> List.iter
(fun (i
, subst
, re
) ->
302 pr2
("transform state: " ^
(Common.i_to_s i
));
304 adjust_pp_with_indent_and_header
"with rule_elem: " (fun () ->
305 Pretty_print_cocci.print_plus_flag
:= true;
306 Pretty_print_cocci.print_minus_flag
:= true;
307 Pretty_print_cocci.rule_elem
"" re
;
309 adjust_pp_with_indent_and_header
"with binding: " (fun () ->
310 Pretty_print_engine.pp_binding subst
;
317 let show_or_not_trans_info a
=
318 Common.profile_code
"show_xxx" (fun () -> show_or_not_trans_info2 a
)
322 let show_or_not_binding2 s binding
=
323 if !Flag_cocci.show_binding_in_out
then begin
324 adjust_pp_with_indent_and_header
("binding " ^ s ^
" = ") (fun () ->
325 Pretty_print_engine.pp_binding binding
328 let show_or_not_binding a b
=
329 Common.profile_code
"show_xxx" (fun () -> show_or_not_binding2 a b
)
333 (*****************************************************************************)
334 (* Some helper functions *)
335 (*****************************************************************************)
337 let worth_trying cfiles tokens
=
338 (* drop the following line for a list of list by rules. since we don't
339 allow multiple minirules, all the tokens within a rule should be in
340 a single CFG entity *)
341 let tokens = Common.union_all
tokens in
342 if not
!Flag_cocci.windows
&& not
(null
tokens)
344 (* could also modify the code in get_constants.ml *)
345 let tokens = tokens +> List.map
(fun s
->
347 | _
when s
=~
"^[A-Za-z_][A-Za-z_0-9]*$" ->
350 | _
when s
=~
"^[A-Za-z_]" ->
353 | _
when s
=~
".*[A-Za-z_]$" ->
358 let com = sprintf
"egrep -q '(%s)' %s" (join
"|" tokens) (join
" " cfiles
)
360 (match Sys.command
com with
361 | 0 (* success *) -> true
364 then Printf.printf
"grep failed: %s\n" com);
365 false (* no match, so not worth trying *)
369 let check_macro_in_sp_and_adjust tokens =
370 let tokens = Common.union_all
tokens in
371 tokens +> List.iter
(fun s
->
372 if Hashtbl.mem
!Parsing_hacks._defs s
374 pr2
"warning: macro in semantic patch was in macro definitions";
375 pr2
("disabling macro expansion for " ^ s
);
376 Hashtbl.remove
!Parsing_hacks._defs s
381 let contain_loop gopt
=
384 g#nodes#tolist
+> List.exists
(fun (xi
, node
) ->
385 Control_flow_c.extract_is_loop node
387 | None
-> true (* means nothing, if no g then will not model check *)
391 let sp_contain_typed_metavar_z toplevel_list_list
=
392 let bind x y
= x
or y
in
393 let option_default = false in
394 let mcode _ _
= option_default in
395 let donothing r k e
= k e
in
397 let expression r k e
=
398 match Ast_cocci.unwrap e
with
399 | Ast_cocci.MetaExpr
(_
,_
,_
,Some t
,_
,_
) -> true
400 | Ast_cocci.MetaExpr
(_
,_
,_
,_
,Ast_cocci.LocalID
,_
) -> true
405 Visitor_ast.combiner bind option_default
406 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
408 donothing donothing donothing donothing
409 donothing expression donothing donothing donothing donothing donothing
410 donothing donothing donothing donothing donothing
412 toplevel_list_list
+>
414 (function (nm
,_
,rule
) ->
415 (List.exists
combiner.Visitor_ast.combiner_top_level rule
))
418 let sp_contain_typed_metavar rules
=
419 sp_contain_typed_metavar_z
423 Ast_cocci.CocciRule
(a
,b
,c
,d
) -> (a
,b
,c
)
424 | _
-> failwith
"error in filter")
427 match x
with Ast_cocci.CocciRule _
-> true | _
-> false)
432 (* finding among the #include the one that we need to parse
433 * because they may contain useful type definition or because
434 * we may have to modify them
436 * For the moment we base in part our heuristic on the name of the file, e.g.
437 * serio.c is related we think to #include <linux/serio.h>
440 let includes_to_parse xs =
441 if !Flag_cocci.no_includes
444 xs +> List.map
(fun (file
, cs
) ->
445 let dir = Common.dirname file
in
447 cs
+> Common.map_filter
(fun (c
,_info_item
) ->
449 | Ast_c.Include
((x
,ii
),info_h_pos
) ->
452 let f = Filename.concat
dir (Common.join
"/" xs) in
453 (* for our tests, all the files are flat in the current dir *)
454 if not
(Sys.file_exists
f) && !Flag_cocci.relax_include_path
456 let attempt2 = Filename.concat
dir (Common.last
xs) in
457 if not
(Sys.file_exists
f) && !Flag_cocci.all_includes
458 then Some
(Filename.concat
!Flag_cocci.include_path
459 (Common.join
"/" xs))
463 | Ast_c.NonLocal
xs ->
464 if !Flag_cocci.all_includes
||
465 Common.fileprefix
(Common.last
xs) = Common.fileprefix file
467 Some
(Filename.concat
!Flag_cocci.include_path
468 (Common.join
"/" xs))
470 | Ast_c.Wierd _
-> None
478 let rec interpret_dependencies local global
= function
479 Ast_cocci.Dep s
-> List.mem s local
480 | Ast_cocci.AntiDep s
->
481 (if !Flag_ctl.steps
!= None
482 then failwith
"steps and ! dependency incompatible");
483 not
(List.mem s local
)
484 | Ast_cocci.EverDep s
-> List.mem s global
485 | Ast_cocci.NeverDep s
->
486 (if !Flag_ctl.steps
!= None
487 then failwith
"steps and ! dependency incompatible");
488 not
(List.mem s global
)
489 | Ast_cocci.AndDep
(s1
,s2
) ->
490 (interpret_dependencies local global s1
) &&
491 (interpret_dependencies local global s2
)
492 | Ast_cocci.OrDep
(s1
,s2
) ->
493 (interpret_dependencies local global s1
) or
494 (interpret_dependencies local global s2
)
495 | Ast_cocci.NoDep
-> true
497 let rec print_dependencies local global
=
499 let rec loop = function
500 Ast_cocci.Dep s
| Ast_cocci.AntiDep s
->
501 if not
(List.mem s
!seen)
505 then pr2
(s^
" satisfied")
506 else pr2
(s^
" not satisfied");
509 | Ast_cocci.EverDep s
| Ast_cocci.NeverDep s
->
510 if not
(List.mem s
!seen)
514 then pr2
(s^
" satisfied")
515 else pr2
(s^
" not satisfied");
518 | Ast_cocci.AndDep
(s1
,s2
) ->
519 print_dependencies local global s1
;
520 print_dependencies local global s2
521 | Ast_cocci.OrDep
(s1
,s2
) ->
522 print_dependencies local global s1
;
523 print_dependencies local global s2
524 | Ast_cocci.NoDep
-> () in
530 (* --------------------------------------------------------------------- *)
531 (* #include relative position in the file *)
532 (* --------------------------------------------------------------------- *)
534 (* compute the set of new prefixes
536 * "a/b/x"; (* in fact it is now a list of string so ["a";"b";"x"] *)
540 * it would give
for the first element
541 * ""; "a"; "a/b"; "a/b/x"
545 * update
: if the
include is inside a ifdef a put nothing
. cf
-test incl
.
546 * this is because we dont want code added inside ifdef
.
549 let compute_new_prefixes xs =
550 xs +> Common.map_withenv
(fun already
xs ->
551 let subdirs_prefixes = Common.inits
xs in
552 let new_first = subdirs_prefixes +> List.filter
(fun x
->
553 not
(List.mem x already
)
562 (* does via side effect on the ref in the Include in Ast_c *)
563 let rec update_include_rel_pos cs
=
564 let only_include = cs
+> Common.map_filter
(fun c
->
566 | Ast_c.Include
((x
,_
),(aref
, inifdef
)) ->
568 | Ast_c.Wierd _
-> None
577 let (locals
, nonlocals
) =
578 only_include +> Common.partition_either
(fun (c
, aref
) ->
580 | Ast_c.Local x
-> Left
(x
, aref
)
581 | Ast_c.NonLocal x
-> Right
(x
, aref
)
582 | Ast_c.Wierd x
-> raise Impossible
585 update_rel_pos_bis locals
;
586 update_rel_pos_bis nonlocals
;
588 and update_rel_pos_bis
xs =
589 let xs'
= List.map fst
xs in
590 let the_first = compute_new_prefixes xs'
in
591 let the_last = List.rev
(compute_new_prefixes (List.rev
xs'
)) in
592 let merged = Common.zip
xs (Common.zip
the_first the_last) in
593 merged +> List.iter
(fun ((x
, aref
), (the_first, the_last)) ->
596 Ast_c.first_of
= the_first;
597 Ast_c.last_of
= the_last;
606 (*****************************************************************************)
607 (* All the information needed around the C elements and Cocci rules *)
608 (*****************************************************************************)
610 type toplevel_c_info
= {
611 ast_c
: Ast_c.toplevel
; (* contain refs so can be modified *)
612 tokens_c
: Parser_c.token list
;
615 flow
: Control_flow_c.cflow
option; (* it's the "fixed" flow *)
618 env_typing_before
: TAC.environment
;
619 env_typing_after
: TAC.environment
;
621 was_modified
: bool ref;
626 type toplevel_cocci_info_script_rule
= {
627 scr_ast_rule
: string * (string * (string * string)) list
* string;
629 scr_dependencies
: Ast_cocci.dependency
;
634 type toplevel_cocci_info_cocci_rule
= {
635 ctl
: Lib_engine.ctlcocci
* (CCI.pred list list
);
636 ast_rule
: Ast_cocci.rule
;
637 isexp
: bool; (* true if + code is an exp, only for Flag.make_hrule *)
640 dependencies
: Ast_cocci.dependency
;
641 (* There are also some hardcoded rule names in parse_cocci.ml:
642 * let reserved_names = ["all";"optional_storage";"optional_qualifier"]
644 dropped_isos
: string list
;
645 free_vars
: Ast_cocci.meta_name list
;
646 negated_pos_vars
: Ast_cocci.meta_name list
;
647 used_after
: Ast_cocci.meta_name list
;
648 positions
: Ast_cocci.meta_name list
;
652 was_matched
: bool ref;
655 type toplevel_cocci_info
=
656 ScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
657 | CocciRuleCocciInfo
of toplevel_cocci_info_cocci_rule
659 type kind_file
= Header
| Source
663 was_modified_once
: bool ref;
664 asts
: toplevel_c_info list
;
669 let g_contain_typedmetavar = ref false
672 let last_env_toplevel_c_info xs =
673 (Common.last
xs).env_typing_after
675 let concat_headers_and_c ccs
=
676 (List.concat
(ccs
+> List.map
(fun x
-> x
.asts
)))
678 let for_unparser xs =
679 xs +> List.map
(fun x
->
680 (x
.ast_c
, (x
.fullstring
, x
.tokens_c
)), Unparse_c2.PPviastr
683 (* --------------------------------------------------------------------- *)
684 let prepare_cocci ctls free_var_lists negated_pos_lists
685 used_after_lists positions_list astcocci
=
687 let gathered = Common.index_list_1
688 (zip
(zip
(zip
(zip
(zip ctls astcocci
) free_var_lists
)
689 negated_pos_lists
) used_after_lists
) positions_list
)
692 (fun ((((((ctl_toplevel_list
,ast
),free_var_list
),negated_pos_list
),
694 positions_list
),rulenb
) ->
696 let is_script_rule r
=
697 match r
with Ast_cocci.ScriptRule _
-> true | _
-> false in
699 if not
(List.length ctl_toplevel_list
= 1) && not
(is_script_rule ast
)
700 then failwith
"not handling multiple minirules";
703 Ast_cocci.ScriptRule
(lang
,deps
,mv
,code
) ->
706 scr_ast_rule
= (lang
, mv
, code
);
708 scr_dependencies
= deps
;
712 in ScriptRuleCocciInfo
r
713 | Ast_cocci.CocciRule
714 (rulename
,(dependencies
,dropped_isos
,z
),restast
,isexp
) ->
717 ctl
= List.hd ctl_toplevel_list
;
719 isexp
= List.hd isexp
;
721 dependencies
= dependencies
;
722 dropped_isos
= dropped_isos
;
723 free_vars
= List.hd free_var_list
;
724 negated_pos_vars
= List.hd negated_pos_list
;
725 used_after
= List.hd used_after_list
;
726 positions
= List.hd positions_list
;
728 was_matched
= ref false;
733 (* --------------------------------------------------------------------- *)
735 let build_info_program cprogram env
=
736 let (cs
, parseinfos
) = Common.unzip cprogram
in
738 Common.unzip
(TAC.annotate_program env
!g_contain_typedmetavar cs
) in
740 zip
(zip cs parseinfos
) envs
+> List.map
(fun ((c
, parseinfo
), (enva
,envb
))->
741 let (fullstr
, tokens) = parseinfo
in
744 ast_to_flow_with_error_messages c
+> Common.map_option
(fun flow ->
745 let flow = Ast_to_flow.annotate_loop_nodes
flow in
747 (* remove the fake nodes for julia *)
748 let fixed_flow = CCI.fix_flow_ctl
flow in
750 if !Flag_cocci.show_flow
then print_flow fixed_flow;
751 if !Flag_cocci.show_before_fixed_flow
then print_flow flow;
758 ast_c
= c
; (* contain refs so can be modified *)
760 fullstring
= fullstr
;
764 contain_loop = contain_loop flow;
766 env_typing_before
= enva
;
767 env_typing_after
= envb
;
769 was_modified
= ref false;
775 (* Optimisation. Try not unparse/reparse the whole file when have modifs *)
776 let rebuild_info_program cs file isexp
=
777 cs
+> List.map
(fun c
->
780 (match !Flag.make_hrule
with
782 Unparse_hrule.pp_program
(c
.ast_c
, (c
.fullstring
, c
.tokens_c
))
786 let file = Common.new_temp_file
"cocci_small_output" ".c" in
788 [(c
.ast_c
, (c
.fullstring
, c
.tokens_c
)), Unparse_c2.PPnormal
]
791 (* Common.command2 ("cat " ^ file); *)
792 let cprogram = cprogram_of_file file in
793 let xs = build_info_program cprogram c
.env_typing_before
in
795 (* TODO: assert env has not changed,
796 * if yes then must also reparse what follows even if not modified.
797 * Do that only if contain_typedmetavar of course, so good opti.
799 (* Common.list_init xs *) (* get rid of the FinalDef *)
805 let rebuild_info_c_and_headers ccs isexp
=
806 ccs
+> List.iter
(fun c_or_h
->
807 if c_or_h
.asts
+> List.exists
(fun c
-> !(c
.was_modified
))
808 then c_or_h
.was_modified_once
:= true;
810 ccs
+> List.map
(fun c_or_h
->
812 asts
= rebuild_info_program c_or_h
.asts c_or_h
.full_fname isexp
}
821 let prepare_c files
=
822 let cprograms = List.map
cprogram_of_file_cached files
in
823 let includes = includes_to_parse (zip files
cprograms) in
825 (* todo?: may not be good to first have all the headers and then all the c *)
827 (includes +> List.map
(fun hpath
-> Right hpath
))
829 ((zip files
cprograms) +> List.map
(fun (file, asts
) -> Left
(file, asts
)))
832 let env = ref TAC.initial_env
in
834 let ccs = all +> Common.map_filter
(fun x
->
837 if not
(Common.lfile_exists hpath
)
839 pr2
("TYPE: header " ^ hpath ^
" not found");
843 let h_cs = cprogram_of_file_cached hpath
in
844 let info_h_cs = build_info_program h_cs !env in
848 else last_env_toplevel_c_info info_h_cs
851 fname
= Common.basename hpath
;
854 was_modified_once
= ref false;
858 | Left
(file, cprogram) ->
859 (* todo?: don't update env ? *)
860 let cs = build_info_program cprogram !env in
861 (* we do that only for the c, not for the h *)
862 ignore
(update_include_rel_pos (cs +> List.map
(fun x
-> x
.ast_c
)));
864 fname
= Common.basename
file;
867 was_modified_once
= ref false;
876 (*****************************************************************************)
877 (* Processing the ctls and toplevel C elements *)
878 (*****************************************************************************)
880 (* The main algorithm =~
881 * The algorithm is roughly:
882 * for_all ctl rules in SP
883 * for_all minirule in rule (no more)
884 * for_all binding (computed during previous phase)
886 * match control flow of function vs minirule
887 * with the binding and update the set of possible
888 * bindings, and returned the possibly modified function.
889 * pretty print modified C elements and reparse it.
892 * On ne prends que les newbinding ou returned_any_state est vrai.
893 * Si ca ne donne rien, on prends ce qu'il y avait au depart.
894 * Mais au nouveau depart de quoi ?
895 * - si ca donne rien apres avoir traité toutes les fonctions avec ce binding ?
896 * - ou alors si ca donne rien, apres avoir traité toutes les fonctions
897 * avec tous les bindings du round d'avant ?
899 * Julia pense qu'il faut prendre la premiere solution.
900 * Example: on a deux environnements candidats, E1 et E2 apres avoir traité
901 * la regle ctl 1. On arrive sur la regle ctl 2.
902 * E1 ne donne rien pour la regle 2, on garde quand meme E1 pour la regle 3.
903 * E2 donne un match a un endroit et rend E2' alors on utilise ca pour
906 * I have not to look at used_after_list to decide to restart from
907 * scratch. I just need to look if the binding list is empty.
908 * Indeed, let's suppose that a SP have 3 regions/rules. If we
909 * don't find a match for the first region, then if this first
910 * region does not bind metavariable used after, that is if
911 * used_after_list is empty, then mysat(), even if does not find a
912 * match, will return a Left, with an empty transformation_info,
913 * and so current_binding will grow. On the contrary if the first
914 * region must bind some metavariables used after, and that we
915 * dont find any such region, then mysat() will returns lots of
916 * Right, and current_binding will not grow, and so we will have
917 * an empty list of binding, and we will catch such a case.
919 * opti: julia says that because the binding is
920 * determined by the used_after_list, the items in the list
921 * are kind of sorted, so could optimise the insert_set operations.
925 (* r(ule), c(element in C code), e(nvironment) *)
927 let rec apply_python_rule r cache newes e rules_that_have_matched
928 rules_that_have_ever_matched
=
929 show_or_not_scr_rule_name r.scr_ruleid
;
930 if not
(interpret_dependencies rules_that_have_matched
931 !rules_that_have_ever_matched
r.scr_dependencies
)
937 pr2
("dependencies for script not satisfied:");
938 print_dependencies rules_that_have_matched
939 !rules_that_have_ever_matched
r.scr_dependencies
;
940 show_or_not_binding "in environment" e
942 (cache
, (e
, rules_that_have_matched
)::newes
)
946 let (_
, mv
, _
) = r.scr_ast_rule
in
947 show_or_not_binding "in" e
;
948 if List.for_all
(Pycocci.contains_binding e
) mv
951 let relevant_bindings =
953 (function ((re
,rm
),_
) ->
954 List.exists
(function (_
,(r,m
)) -> r = re
&& m
= rm
) mv
)
957 if List.mem
relevant_bindings cache
961 Pycocci.build_classes
(List.map
(function (x
,y
) -> x
) e
);
962 Pycocci.construct_variables mv e
;
963 let _ = Pycocci.pyrun_simplestring
964 ("import coccinelle\nfrom coccinelle "^
965 "import *\ncocci = Cocci()\n" ^
967 relevant_bindings :: cache
969 if !Pycocci.inc_match
970 then (new_cache, (e
, rules_that_have_matched
)::newes
)
971 else (new_cache, newes
)
973 else (cache
, (e
, rules_that_have_matched
)::newes
)
976 and apply_cocci_rule
r rules_that_have_ever_matched es
ccs =
977 Common.profile_code
r.rulename
(fun () ->
978 show_or_not_rule_name r.ast_rule
r.ruleid
;
979 show_or_not_ctl_text r.ctl
r.ast_rule
r.ruleid
;
981 let reorganized_env =
982 reassociate_positions
r.free_vars
r.negated_pos_vars
!es
in
984 (* looping over the environments *)
985 let (_,newes
(* envs for next round/rule *)) =
987 (function (cache
,newes
) ->
988 function ((e
,rules_that_have_matched
),relevant_bindings) ->
989 if not
(interpret_dependencies rules_that_have_matched
990 !rules_that_have_ever_matched
r.dependencies
)
997 ("dependencies for rule "^
r.rulename^
" not satisfied:");
998 print_dependencies rules_that_have_matched
999 !rules_that_have_ever_matched
r.dependencies
;
1000 show_or_not_binding "in environment" e
1003 Common.union_set newes
1004 [(e
+> List.filter
(fun (s
,v
) -> List.mem s
r.used_after
),
1005 rules_that_have_matched
)])
1009 try List.assoc
relevant_bindings cache
1013 show_or_not_binding "in" e
;
1014 show_or_not_binding "relevant in" relevant_bindings;
1016 let children_e = ref [] in
1018 (* looping over the functions and toplevel elements in
1020 concat_headers_and_c !ccs +> List.iter
(fun c
->
1023 (* does also some side effects on c and r *)
1025 process_a_ctl_a_env_a_toplevel
r relevant_bindings
1027 match processed with
1029 | Some newbindings
->
1030 newbindings
+> List.iter
(fun newbinding
->
1032 Common.insert_set newbinding
!children_e)
1033 ); (* end iter cs *)
1037 let old_bindings_to_keep =
1039 (e
+> List.filter
(fun (s
,v
) -> List.mem s
r.used_after
)) in
1041 if null
new_bindings
1044 (*use the old bindings, specialized to the used_after_list*)
1045 if !Flag_ctl.partial_match
1048 "Empty list of bindings, I will restart from old env";
1049 [(old_bindings_to_keep,rules_that_have_matched
)]
1052 (* combine the new bindings with the old ones, and
1053 specialize to the used_after_list *)
1054 let old_variables = List.map fst
old_bindings_to_keep in
1055 (* have to explicitly discard the inherited variables
1056 because we want the inherited value of the positions
1057 variables not the extended one created by
1058 reassociate_positions. want to reassociate freshly
1059 according to the free variables of each rule. *)
1060 let new_bindings_to_add =
1066 List.mem s
r.used_after
&&
1067 not
(List.mem s
old_variables)))) in
1069 (function new_binding_to_add
->
1071 old_bindings_to_keep new_binding_to_add
,
1072 r.rulename
::rules_that_have_matched
))
1073 new_bindings_to_add in
1074 ((relevant_bindings,new_bindings)::cache
,
1075 Common.union_set
new_e newes
))
1076 ([],[]) reorganized_env in (* end iter es *)
1078 then Common.push2
r.rulename rules_that_have_ever_matched
;
1082 (* apply the tagged modifs and reparse *)
1083 if not
!Flag.sgrep_mode2
1084 then ccs := rebuild_info_c_and_headers !ccs r.isexp
1087 and bigloop2 rs
ccs =
1088 let es = ref [(Ast_c.emptyMetavarsBinding
,[])] in
1089 let ccs = ref ccs in
1090 let rules_that_have_ever_matched = ref [] in
1092 (* looping over the rules *)
1093 rs
+> List.iter
(fun r ->
1095 ScriptRuleCocciInfo
r ->
1096 if !Flag_cocci.show_ctl_text
then begin
1097 Common.pr_xxxxxxxxxxxxxxxxx
();
1098 pr
("script: " ^
r.language
);
1099 Common.pr_xxxxxxxxxxxxxxxxx
();
1101 adjust_pp_with_indent
(fun () ->
1102 Format.force_newline
();
1103 let (l
,mv
,code
) = r.scr_ast_rule
in
1104 let deps = r.scr_dependencies
in
1105 Pretty_print_cocci.unparse
1106 (Ast_cocci.ScriptRule
(l
,deps,mv
,code
)));
1109 if !Flag.show_misc
then print_endline
"RESULT =";
1113 (function (cache
, newes
) ->
1114 function (e
, rules_that_have_matched
) ->
1115 match r.language
with
1117 apply_python_rule r cache newes e rules_that_have_matched
1118 rules_that_have_ever_matched
1120 concat_headers_and_c !ccs +> List.iter
(fun c
->
1123 Printf.printf
"Flow: %s\r\nFlow!\r\n%!" c
.fullstring
);
1126 Printf.printf
"Unknown language: %s\n" r.language
;
1132 | CocciRuleCocciInfo
r ->
1133 apply_cocci_rule
r rules_that_have_ever_matched es ccs);
1135 if !Flag.sgrep_mode2
1137 (* sgrep can lead to code that is not parsable, but we must
1138 * still call rebuild_info_c_and_headers to pretty print the
1139 * action (MINUS), so that later the diff will show what was
1140 * matched by sgrep. But we don't want the parsing error message
1141 * hence the following flag setting. So this code propably
1142 * will generate a NotParsedCorrectly for the matched parts
1143 * and the very final pretty print and diff will work
1145 Flag_parsing_c.verbose_parsing
:= false;
1146 ccs := rebuild_info_c_and_headers !ccs false
1148 !ccs (* return final C asts *)
1150 and reassociate_positions free_vars negated_pos_vars envs
=
1151 (* issues: isolate the bindings that are relevant to a given rule.
1152 separate out the position variables
1153 associate all of the position variables for a given set of relevant
1154 normal variable bindings with each set of relevant normal variable
1155 bindings. Goal: if eg if@p (E) matches in two places, then both inherited
1156 occurrences of E should see both bindings of p, not just its own.
1157 Otherwise, a position constraint for something that matches in two
1158 places will never be useful, because the position can always be
1159 different from the other one. *)
1163 List.filter
(function (x
,_) -> List.mem x free_vars
) e
)
1165 let splitted_relevant =
1166 (* separate the relevant variables into the non-position ones and the
1171 (function (non_pos
,pos
) ->
1172 function (v
,_) as x
->
1173 if List.mem v negated_pos_vars
1174 then (non_pos
,x
::pos
)
1175 else (x
::non_pos
,pos
))
1178 let splitted_relevant =
1180 (function (non_pos
,pos
) ->
1181 (List.sort compare non_pos
,List.sort compare pos
))
1182 splitted_relevant in
1185 (function non_pos
->
1187 if List.mem np non_pos
then non_pos
else np
::non_pos
)
1188 [] splitted_relevant in
1189 let extended_relevant =
1190 (* extend the position variables with the values found at other identical
1191 variable bindings *)
1193 (function non_pos
->
1196 (function (other_non_pos
,other_pos
) ->
1197 (* do we want equal? or just somehow compatible? eg non_pos
1198 binds only E, but other_non_pos binds both E and E1 *)
1199 non_pos
= other_non_pos
)
1200 splitted_relevant in
1204 (combine_pos negated_pos_vars
1205 (List.map
(function (_,x
) -> x
) others)))))
1208 (List.map
(function (non_pos
,_) -> List.assoc non_pos
extended_relevant)
1211 and combine_pos negated_pos_vars
others =
1215 Ast_c.MetaPosValList
1218 (function positions
->
1219 function other_list
->
1221 match List.assoc posvar other_list
with
1222 Ast_c.MetaPosValList l1
->
1223 Common.union_set l1 positions
1224 | _ -> failwith
"bad value for a position variable"
1225 with Not_found
-> positions
)
1230 Common.profile_code
"bigloop" (fun () -> bigloop2 a b
)
1236 (* does side effects on C ast and on Cocci info rule *)
1237 and process_a_ctl_a_env_a_toplevel2
r e c
=
1238 indent_do
(fun () ->
1239 show_or_not_celem "trying" c
.ast_c
;
1240 let (trans_info, returned_any_states
, newbindings
) =
1241 Common.save_excursion
Flag_ctl.loop_in_src_code
(fun () ->
1242 Flag_ctl.loop_in_src_code
:= !Flag_ctl.loop_in_src_code
||c
.contain_loop;
1244 (***************************************)
1245 (* !Main point! The call to the engine *)
1246 (***************************************)
1247 let model_ctl = CCI.model_for_ctl
r.dropped_isos
(Common.some c
.flow) e
1248 in CCI.mysat
model_ctl r.ctl
(r.used_after
, e
)
1251 if not returned_any_states
1254 show_or_not_celem "found match in" c
.ast_c
;
1255 show_or_not_trans_info trans_info;
1256 List.iter
(show_or_not_binding "out") newbindings
;
1258 r.was_matched
:= true;
1260 if not
(null
trans_info)
1262 c
.was_modified
:= true;
1264 (* les "more than one var in a decl" et "already tagged token"
1265 * font crasher coccinelle. Si on a 5 fichiers, donc on a 5
1266 * failed. Le try limite le scope des crashes pendant la
1267 * trasformation au fichier concerne. *)
1269 (* modify ast via side effect *)
1270 ignore
(Transformation3.transform
r.rulename
r.dropped_isos
1271 trans_info (Common.some c
.flow));
1272 with Timeout
-> raise Timeout
| UnixExit i
-> raise
(UnixExit i
)
1279 and process_a_ctl_a_env_a_toplevel a b c
=
1280 Common.profile_code
"process_a_ctl_a_env_a_toplevel"
1281 (fun () -> process_a_ctl_a_env_a_toplevel2 a b c
)
1285 (*****************************************************************************)
1286 (* The main function *)
1287 (*****************************************************************************)
1289 let full_engine2 (coccifile
, isofile
) cfiles
=
1291 show_or_not_cfiles cfiles
;
1292 show_or_not_cocci coccifile isofile
;
1293 Pycocci.set_coccifile coccifile
;
1296 if not
(Common.lfile_exists
isofile)
1298 pr2
("warning: Can't find default iso file: " ^
isofile);
1304 (* useful opti when use -dir *)
1305 let (astcocci
,free_var_lists
,negated_pos_lists
,used_after_lists
,
1306 positions_lists
,toks
,_) =
1307 sp_of_file coccifile
isofile
1310 Common.memoized
_hctl (coccifile
, isofile) (fun () ->
1311 ctls_of_ast astcocci used_after_lists positions_lists
)
1314 let contain_typedmetavar = sp_contain_typed_metavar astcocci
in
1316 (* optimisation allowing to launch coccinelle on all the drivers *)
1317 if !Flag_cocci.worth_trying_opt
&& not
(worth_trying cfiles toks
)
1319 pr2
("not worth trying:" ^
Common.join
" " cfiles
);
1320 cfiles
+> List.map
(fun s
-> s
, None
)
1324 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1325 if !Flag.show_misc
then pr
"let's go";
1326 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1328 g_contain_typedmetavar := contain_typedmetavar;
1330 check_macro_in_sp_and_adjust toks
;
1333 prepare_cocci ctls free_var_lists negated_pos_lists
1334 used_after_lists positions_lists astcocci
in
1335 let c_infos = prepare_c cfiles
in
1337 show_or_not_ctl_tex astcocci
ctls;
1339 (* ! the big loop ! *)
1340 let c_infos'
= bigloop
cocci_infos c_infos in
1342 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1343 if !Flag.show_misc
then pr
"Finished";
1344 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1346 c_infos'
+> List.map
(fun c_or_h
->
1347 if !(c_or_h
.was_modified_once
)
1349 let outfile = Common.new_temp_file
"cocci-output" ("-" ^ c_or_h
.fname
)
1352 if c_or_h
.fkind
= Header
1353 then pr2
("a header file was modified: " ^ c_or_h
.fname
);
1355 (* and now unparse everything *)
1356 cfile_of_program (for_unparser c_or_h
.asts
) outfile;
1358 let show_only_minus = !Flag.sgrep_mode2
in
1359 show_or_not_diff c_or_h
.fpath
outfile show_only_minus;
1362 if !Flag.sgrep_mode2
then None
else Some
outfile
1366 (c_or_h
.fpath
, None
)
1370 let full_engine a b
=
1371 Common.profile_code
"full_engine" (fun () -> full_engine2 a b
)
1374 (*****************************************************************************)
1375 (* check duplicate from result of full_engine *)
1376 (*****************************************************************************)
1378 let check_duplicate_modif2 xs =
1379 (* opti: let groups = Common.groupBy (fun (a,resa) (b,resb) -> a =$= b) xs *)
1380 pr2
("Check duplication for " ^ i_to_s
(List.length
xs) ^
" files");
1381 let groups = Common.group_assoc_bykey_eff
xs in
1382 groups +> Common.map_filter
(fun (file, xs) ->
1384 | [] -> raise Impossible
1385 | [res] -> Some
(file, res)
1389 if not
(List.for_all
(fun res2
-> res2
= None
) xs)
1391 pr2
("different modification result for " ^
file);
1394 else Some
(file, None
)
1396 if not
(List.for_all
(fun res2
->
1400 let diff = Common.cmd_to_list
("diff -u -b -B "^
res^
" "^res2
)
1404 pr2
("different modification result for " ^
file);
1407 else Some
(file, Some
res)
1411 let check_duplicate_modif a
=
1412 Common.profile_code
"check_duplicate" (fun () -> check_duplicate_modif2 a
)