2 * Copyright 2012, INRIA
3 * Julia Lawall, Gilles Muller
4 * Copyright 2010-2011, INRIA, University of Copenhagen
5 * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
6 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
7 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
8 * This file is part of Coccinelle.
10 * Coccinelle is free software: you can redistribute it and/or modify
11 * it under the terms of the GNU General Public License as published by
12 * the Free Software Foundation, according to version 2 of the License.
14 * Coccinelle is distributed in the hope that it will be useful,
15 * but WITHOUT ANY WARRANTY; without even the implied warranty of
16 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 * GNU General Public License for more details.
19 * You should have received a copy of the GNU General Public License
20 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
22 * The authors reserve the right to distribute this or future versions of
23 * Coccinelle under other licenses.
29 module CCI
= Ctlcocci_integration
30 module TAC
= Type_annoter_c
32 module Ast_to_flow
= Control_flow_c_build
34 (*****************************************************************************)
35 (* This file is a kind of driver. It gathers all the important functions
36 * from coccinelle in one place. The different entities in coccinelle are:
40 * - flow (contain nodes)
41 * - ctl (contain rule_elems)
42 * This file contains functions to transform one in another.
44 (*****************************************************************************)
46 (* --------------------------------------------------------------------- *)
48 (* --------------------------------------------------------------------- *)
49 let cprogram_of_file saved_typedefs saved_macros file
=
50 let (program2
, _stat
) =
51 Parse_c.parse_c_and_cpp_keep_typedefs
52 (if !Flag_cocci.use_saved_typedefs
then (Some saved_typedefs
) else None
)
53 (Some saved_macros
) file
in
56 let cprogram_of_file_cached file
=
57 let ((program2
,typedefs
,macros
), _stat
) = Parse_c.parse_cache file
in
58 if !Flag_cocci.ifdef_to_if
61 program2
+> Parse_c.with_program2
(fun asts
->
62 Cpp_ast_c.cpp_ifdef_statementize asts
65 else (program2
,typedefs
,macros
)
67 let cfile_of_program program2_with_ppmethod outf
=
68 Unparse_c.pp_program program2_with_ppmethod outf
70 (* for memoization, contains only one entry, the one for the SP *)
71 let _hparse = Hashtbl.create
101
72 let _h_ocaml_init = Hashtbl.create
101
73 let _hctl = Hashtbl.create
101
75 (* --------------------------------------------------------------------- *)
77 (* --------------------------------------------------------------------- *)
78 (* for a given pair (file,iso), only keep an instance for the most recent
79 virtual rules and virtual_env *)
81 let sp_of_file2 file iso
=
84 let (_
,xs
,_
,_
,_
,_
,_
) as res
= Parse_cocci.process file iso
false in
85 (* if there is already a compiled ML code, do nothing and use that *)
86 try let _ = Hashtbl.find
_h_ocaml_init (file
,iso
) in res
89 Hashtbl.add
_h_ocaml_init (file
,iso
) ();
90 match Prepare_ocamlcocci.prepare file xs
with
92 | Some ocaml_script_file
->
94 Prepare_ocamlcocci.load_file ocaml_script_file
;
95 (if not
!Common.save_tmp_files
96 then Prepare_ocamlcocci.clean_file ocaml_script_file
);
99 Hashtbl.add
_hparse (file
,iso
)
100 (!Flag.defined_virtual_rules
,!Flag.defined_virtual_env
,new_code);
103 let (rules
,env
,code
) = Hashtbl.find
_hparse (file
,iso
) in
104 if rules
= !Flag.defined_virtual_rules
&& env
= !Flag.defined_virtual_env
106 else (Hashtbl.remove
_hparse (file
,iso
); redo())
107 with Not_found
-> redo()
109 let sp_of_file file iso
=
110 Common.profile_code
"parse cocci" (fun () -> sp_of_file2 file iso
)
113 (* --------------------------------------------------------------------- *)
115 (* --------------------------------------------------------------------- *)
116 let print_flow flow
=
117 Ograph_extended.print_ograph_mutable flow
"/tmp/test.dot" true
120 let ast_to_flow_with_error_messages2 x
=
122 try Ast_to_flow.ast_to_control_flow x
123 with Ast_to_flow.Error x
->
124 Ast_to_flow.report_error x
;
127 flowopt +> do_option
(fun flow
->
128 (* This time even if there is a deadcode, we still have a
129 * flow graph, so I can try the transformation and hope the
130 * deadcode will not bother us.
132 try Ast_to_flow.deadcode_detection flow
133 with Ast_to_flow.Error
(Ast_to_flow.DeadCode x
) ->
134 Ast_to_flow.report_error
(Ast_to_flow.DeadCode x
);
137 let ast_to_flow_with_error_messages a
=
138 Common.profile_code
"flow" (fun () -> ast_to_flow_with_error_messages2 a
)
141 (* --------------------------------------------------------------------- *)
143 (* --------------------------------------------------------------------- *)
145 let ctls_of_ast2 ast
(ua
,fua
,fuas
) pos
=
147 (function ast
-> function (ua
,(fua
,(fuas
,pos
))) ->
151 else Asttoctl2.asttoctl ast
(ua
,fua
,fuas
) pos
)
152 (Asttomember.asttomember ast ua
))
153 ast
(List.combine ua
(List.combine fua
(List.combine fuas pos
)))
155 let ctls_of_ast ast ua pl
=
156 Common.profile_code
"asttoctl2" (fun () -> ctls_of_ast2 ast ua pl
)
158 (*****************************************************************************)
159 (* Some debugging functions *)
160 (*****************************************************************************)
164 let show_or_not_cfile2 cfile
=
165 if !Flag_cocci.show_c
then begin
166 Common.pr2_xxxxxxxxxxxxxxxxx
();
167 pr2
("processing C file: " ^ cfile
);
168 Common.pr2_xxxxxxxxxxxxxxxxx
();
169 Common.command2
("cat " ^ cfile
);
171 let show_or_not_cfile a
=
172 Common.profile_code
"show_xxx" (fun () -> show_or_not_cfile2 a
)
174 let show_or_not_cfiles cfiles
= List.iter
show_or_not_cfile cfiles
177 let show_or_not_cocci2 coccifile isofile
=
178 if !Flag_cocci.show_cocci
then begin
179 Common.pr2_xxxxxxxxxxxxxxxxx
();
180 pr2
("processing semantic patch file: " ^ coccifile
);
181 isofile
+> (fun s
-> pr2
("with isos from: " ^ s
));
182 Common.pr2_xxxxxxxxxxxxxxxxx
();
183 Common.command2
("cat " ^ coccifile
);
186 let show_or_not_cocci a b
=
187 Common.profile_code
"show_xxx" (fun () -> show_or_not_cocci2 a b
)
189 (* ---------------------------------------------------------------------- *)
192 let fix_sgrep_diffs l
=
194 List.filter
(function s
-> (s
=~
"^\\+\\+\\+") || not
(s
=~
"^\\+")) l in
195 let l = List.rev
l in
196 (* adjust second number for + code *)
197 let rec loop1 n
= function
200 if s
=~
"^-" && not
(s
=~
"^---")
201 then s
:: loop1 (n
+1) ss
204 (match Str.split
(Str.regexp
" ") s
with
207 match Str.split
(Str.regexp
",") pl
with
210 | _ -> failwith
"bad + line information" in
211 let n2 = int_of_string
n2 in
212 (Printf.sprintf
"%s %s %s,%d %s" bef min n1
(n2-n
)
213 (String.concat
" " aft
))
215 | _ -> failwith
"bad @@ information")
216 else s
:: loop1 n ss
in
217 let rec loop2 n
= function
224 (match Str.split
(Str.regexp
" ") s
with
227 match (Str.split
(Str.regexp
",") min
,
228 Str.split
(Str.regexp
",") pl
) with
229 ([_;m2
],[n1
;n2]) -> (m2
,n1
,n2)
230 | ([_],[n1
;n2]) -> ("1",n1
,n2)
231 | ([_;m2
],[n1
]) -> (m2
,n1
,"1")
232 | ([_],[n1
]) -> ("1",n1
,"1")
233 | _ -> failwith
"bad -/+ line information" in
235 int_of_string
(String.sub
n1 1 ((String.length
n1)-1)) in
236 let m2 = int_of_string
m2 in
237 let n2 = int_of_string
n2 in
238 (Printf.sprintf
"%s %s +%d,%d %s" bef min
(n1-n
) n2
239 (String.concat
" " aft
))
240 :: loop2 (n
+(m2-n2)) ss
241 | _ -> failwith
"bad @@ information")
242 else s
:: loop2 n ss
in
243 loop2 0 (List.rev
(loop1 0 l))
245 let normalize_path file
=
247 if String.get file
0 = '
/'
then file
else (Sys.getcwd
()) ^
"/" ^ file
in
248 let elements = Str.split_delim
(Str.regexp
"/") fullpath in
249 let rec loop prev
= function
250 [] -> String.concat
"/" (List.rev prev
)
251 | "." :: rest
-> loop prev rest
254 x
::xs
-> loop xs rest
255 | _ -> failwith
"bad path")
256 | x
::rest
-> loop (x
::prev
) rest
in
259 let generated_patches = Hashtbl.create
(100)
261 let show_or_not_diff2 cfile outfile
=
262 if !Flag_cocci.show_diff
then begin
263 match Common.fst
(Compare_c.compare_to_original cfile outfile
) with
264 Compare_c.Correct
-> () (* diff only in spacing, etc *)
266 (* may need --strip-trailing-cr under windows *)
270 match !Flag_parsing_c.diff_lines
with
271 | None
-> "diff -u -p " ^ cfile ^
" " ^ outfile
272 | Some n
-> "diff -U "^n^
" -p "^cfile^
" "^outfile
in
273 let res = Common.cmd_to_list
line in
277 match Str.split
(Str.regexp
"[ \t]+") l with
278 "---"::file
::date
-> "--- "^file
279 | "+++"::file
::date
-> "+++ "^file
283 match (!Flag.patch
,res) with
284 (* create something that looks like the output of patch *)
285 (Some prefix
,minus_file
::plus_file
::rest
) ->
287 let lp = String.length
prefix in
288 if String.get
prefix (lp-1) = '
/'
289 then String.sub
prefix 0 (lp-1)
291 let drop_prefix file
=
292 let file = normalize_path file in
293 if Str.string_match
(Str.regexp
prefix) file 0
295 let lp = String.length
prefix in
296 let lf = String.length
file in
298 then String.sub
file lp (lf - lp)
301 (Printf.sprintf
"prefix %s doesn't match file %s"
305 (Printf.sprintf
"prefix %s doesn't match file %s"
308 match List.rev
(Str.split
(Str.regexp
" ") line) with
309 new_file
::old_file
::cmdrev
->
310 let old_base_file = drop_prefix old_file
in
315 (("/tmp/nothing"^
old_base_file)
316 :: old_file
:: cmdrev
))
320 (("b"^
old_base_file)::("a"^
old_base_file)::
322 | _ -> failwith
"bad command" in
323 let (minus_line
,plus_line
) =
324 match (Str.split
(Str.regexp
"[ \t]") minus_file
,
325 Str.split
(Str.regexp
"[ \t]") plus_file
) with
326 ("---"::old_file
::old_rest
,"+++"::new_file
::new_rest
) ->
327 let old_base_file = drop_prefix old_file
in
329 then (minus_file
,"+++ /tmp/nothing"^
old_base_file)
332 ("---"::("a"^
old_base_file)::old_rest
),
334 ("+++"::("b"^
old_base_file)::new_rest
))
337 (Printf.sprintf
"bad diff header lines: %s %s"
338 (String.concat
":" l1
) (String.concat
":" l2
)) in
339 diff_line::minus_line
::plus_line
::rest
341 let xs = if !Flag.sgrep_mode2
then fix_sgrep_diffs xs else xs in
342 let cfile = normalize_path cfile in
344 try Hashtbl.find
generated_patches cfile
347 Hashtbl.add
generated_patches cfile cell;
349 if List.mem
xs !patches
353 patches := xs :: !patches;
357 let show_or_not_diff a b
=
358 Common.profile_code
"show_xxx" (fun () -> show_or_not_diff2 a b
)
361 (* the derived input *)
363 let show_or_not_ctl_tex2 astcocci ctls
=
364 if !Flag_cocci.show_ctl_tex
then begin
368 (function ((Asttoctl2.NONDECL ctl
| Asttoctl2.CODE ctl
),x
) ->
371 Ctltotex.totex
("/tmp/__cocci_ctl.tex") astcocci
ctls;
372 Common.command2
("cd /tmp; latex __cocci_ctl.tex; " ^
373 "dvips __cocci_ctl.dvi -o __cocci_ctl.ps;" ^
374 "gv __cocci_ctl.ps &");
376 let show_or_not_ctl_tex a b
=
377 Common.profile_code
"show_xxx" (fun () -> show_or_not_ctl_tex2 a b
)
380 let show_or_not_rule_name ast rulenb
=
381 if !Flag_cocci.show_ctl_text
or !Flag.show_trying
or
382 !Flag.show_transinfo
or !Flag_cocci.show_binding_in_out
387 Ast_cocci.CocciRule
(nm
, (deps
, drops
, exists
), x
, _, _) -> nm
388 | _ -> i_to_s rulenb
in
389 Common.pr_xxxxxxxxxxxxxxxxx
();
391 Common.pr_xxxxxxxxxxxxxxxxx
()
394 let show_or_not_scr_rule_name rulenb
=
395 if !Flag_cocci.show_ctl_text
or !Flag.show_trying
or
396 !Flag.show_transinfo
or !Flag_cocci.show_binding_in_out
399 let name = i_to_s rulenb
in
400 Common.pr_xxxxxxxxxxxxxxxxx
();
401 pr
("script rule " ^
name ^
" = ");
402 Common.pr_xxxxxxxxxxxxxxxxx
()
405 let show_or_not_ctl_text2 ctl ast rulenb
=
406 if !Flag_cocci.show_ctl_text
then begin
408 adjust_pp_with_indent
(fun () ->
409 Format.force_newline
();
410 Pretty_print_cocci.print_plus_flag
:= true;
411 Pretty_print_cocci.print_minus_flag
:= true;
412 Pretty_print_cocci.unparse ast
;
416 let ((Asttoctl2.CODE ctl
| Asttoctl2.NONDECL ctl
),_) = ctl
in
417 adjust_pp_with_indent
(fun () ->
418 Format.force_newline
();
419 Pretty_print_engine.pp_ctlcocci
420 !Flag_cocci.show_mcodekind_in_ctl
!Flag_cocci.inline_let_ctl ctl
;
424 let show_or_not_ctl_text a b c
=
425 Common.profile_code
"show_xxx" (fun () -> show_or_not_ctl_text2 a b c
)
429 (* running information *)
430 let get_celem celem
: string =
432 Ast_c.Definition
({Ast_c.f_name
= namefuncs
;},_) ->
433 Ast_c.str_of_name namefuncs
435 (Ast_c.DeclList
([{Ast_c.v_namei
= Some
(name, _);}, _], _)) ->
436 Ast_c.str_of_name
name
439 let show_or_not_celem2 prelude celem
=
442 | Ast_c.Definition
({Ast_c.f_name
= namefuncs
},_) ->
443 let funcs = Ast_c.str_of_name namefuncs
in
444 Flag.current_element
:= funcs;
445 (" function: ",funcs)
447 (Ast_c.DeclList
([{Ast_c.v_namei
= Some
(name,_)}, _], _)) ->
448 let s = Ast_c.str_of_name
name in
449 Flag.current_element
:= s;
452 Flag.current_element
:= "something_else";
453 (" ","something else");
455 if !Flag.show_trying
then pr2
(prelude ^ tag ^ trying
)
457 let show_or_not_celem a b
=
458 Common.profile_code
"show_xxx" (fun () -> show_or_not_celem2 a b
)
461 let show_or_not_trans_info2 trans_info
=
462 (* drop witness tree indices for printing *)
464 List.map
(function (index
,trans_info) -> trans_info) trans_info in
465 if !Flag.show_transinfo
then begin
466 if null
trans_info then pr2
"transformation info is empty"
468 pr2
"transformation info returned:";
470 List.sort
(function (i1
,_,_) -> function (i2
,_,_) -> compare i1 i2
)
474 trans_info +> List.iter
(fun (i
, subst
, re
) ->
475 pr2
("transform state: " ^
(Common.i_to_s i
));
477 adjust_pp_with_indent_and_header
"with rule_elem: " (fun () ->
478 Pretty_print_cocci.print_plus_flag
:= true;
479 Pretty_print_cocci.print_minus_flag
:= true;
480 Pretty_print_cocci.rule_elem
"" re
;
482 adjust_pp_with_indent_and_header
"with binding: " (fun () ->
483 Pretty_print_engine.pp_binding subst
;
490 let show_or_not_trans_info a
=
491 Common.profile_code
"show_xxx" (fun () -> show_or_not_trans_info2 a
)
495 let show_or_not_binding2 s binding
=
496 if !Flag_cocci.show_binding_in_out
then begin
497 adjust_pp_with_indent_and_header
("binding " ^
s ^
" = ") (fun () ->
498 Pretty_print_engine.pp_binding binding
501 let show_or_not_binding a b
=
502 Common.profile_code
"show_xxx" (fun () -> show_or_not_binding2 a b
)
506 (*****************************************************************************)
507 (* Some helper functions *)
508 (*****************************************************************************)
510 let worth_trying cfiles tokens
=
511 (* drop the following line for a list of list by rules. since we don't
512 allow multiple minirules, all the tokens within a rule should be in
513 a single CFG entity *)
514 match (!Flag_cocci.windows
,tokens
) with
515 (true,_) | (_,None
) -> true
517 (* could also modify the code in get_constants.ml *)
518 let tokens = tokens +> List.map
(fun s ->
520 | _ when s =~
"^[A-Za-z_][A-Za-z_0-9]*$" ->
523 | _ when s =~
"^[A-Za-z_]" ->
526 | _ when s =~
".*[A-Za-z_]$" ->
531 let com = sprintf
"egrep -q '(%s)' %s" (join
"|" tokens) (join
" " cfiles
)
533 (match Sys.command
com with
534 | 0 (* success *) -> true
537 then Printf.printf
"grep failed: %s\n" com);
538 false (* no match, so not worth trying *))
540 let check_macro_in_sp_and_adjust = function
543 tokens +> List.iter
(fun s ->
544 if Hashtbl.mem
!Parse_c._defs
s
546 if !Flag_cocci.verbose_cocci
then begin
547 pr2
"warning: macro in semantic patch was in macro definitions";
548 pr2
("disabling macro expansion for " ^
s);
550 Hashtbl.remove
!Parse_c._defs
s
554 let contain_loop gopt
=
557 g#nodes#tolist
+> List.exists
(fun (xi
, node
) ->
558 Control_flow_c.extract_is_loop node
560 | None
-> true (* means nothing, if no g then will not model check *)
564 let sp_contain_typed_metavar_z toplevel_list_list
=
565 let bind x y
= x
or y
in
566 let option_default = false in
567 let mcode _ _ = option_default in
568 let donothing r k e
= k e
in
570 let expression r k e
=
571 match Ast_cocci.unwrap e
with
572 | Ast_cocci.MetaExpr
(_,_,_,Some t
,_,_) -> true
573 | Ast_cocci.MetaExpr
(_,_,_,_,Ast_cocci.LocalID
,_) -> true
578 Visitor_ast.combiner bind option_default
579 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
580 donothing donothing donothing donothing donothing
581 donothing expression donothing donothing donothing donothing donothing
582 donothing donothing donothing donothing donothing
584 toplevel_list_list
+>
586 (function (nm
,_,rule
) ->
587 (List.exists
combiner.Visitor_ast.combiner_top_level rule
))
589 let sp_contain_typed_metavar rules
=
590 sp_contain_typed_metavar_z
594 Ast_cocci.CocciRule
(a
,b
,c
,d
,_) -> (a
,b
,c
)
595 | _ -> failwith
"error in filter")
599 Ast_cocci.CocciRule
(a
,b
,c
,d
,Ast_cocci.Normal
) -> true
605 (* finding among the #include the one that we need to parse
606 * because they may contain useful type definition or because
607 * we may have to modify them
609 * For the moment we base in part our heuristic on the name of the file, e.g.
610 * serio.c is related we think to #include <linux/serio.h>
612 let include_table = Hashtbl.create
(100)
614 let interpret_include_path relpath
=
615 let maxdepth = List.length relpath
in
616 let unique_file_exists dir f
=
618 Printf.sprintf
"find %s -maxdepth %d -mindepth %d -path \"*/%s\""
619 dir
maxdepth maxdepth f
in
620 match Common.cmd_to_list
cmd with
623 let native_file_exists dir f
=
624 let f = Filename.concat dir
f in
628 let rec search_include_path exists searchlist relpath
=
629 match searchlist
with
632 (match exists hd relpath
with
634 | None
-> search_include_path exists tail relpath
) in
635 let rec search_path exists searchlist
= function
637 let res = Common.concat
"/" relpath
in
638 Hashtbl.add
include_table (searchlist
,relpath
) res;
640 | (hd
::tail
) as relpath1
->
641 let relpath1 = Common.concat
"/" relpath1 in
642 (match search_include_path exists searchlist
relpath1 with
643 None
-> search_path unique_file_exists searchlist tail
645 Hashtbl.add
include_table (searchlist
,relpath
) f;
648 match !Flag_cocci.include_path
with
651 try Some
(Hashtbl.find
include_table (searchlist,relpath
))
653 search_path native_file_exists searchlist relpath
655 let (includes_to_parse
:
656 (Common.filename
* Parse_c.extended_program2
) list
->
657 Flag_cocci.include_options
-> 'a
) = fun xs choose_includes
->
658 match choose_includes
with
659 Flag_cocci.I_UNSPECIFIED
-> failwith
"not possible"
660 | Flag_cocci.I_NO_INCLUDES
-> []
664 [Flag_cocci.I_ALL_INCLUDES
; Flag_cocci.I_REALLY_ALL_INCLUDES
] in
665 let xs = List.map
(function (file,(cs
,_,_)) -> (file,cs
)) xs in
666 xs +> List.map
(fun (file, cs
) ->
667 let dir = Common.dirname
file in
669 cs
+> Common.map_filter
(fun (c
,_info_item
) ->
673 {Ast_c.i_include
= ((x
,ii
)); i_rel_pos
= info_h_pos
;}) ->
676 let relpath = Common.join
"/" xs in
677 let f = Filename.concat
dir relpath in
678 if (Sys.file_exists
f) then
681 if !Flag_cocci.relax_include_path
682 (* for our tests, all the files are flat in the current dir *)
684 let attempt2 = Filename.concat
dir (Common.last
xs) in
685 if not
(Sys.file_exists
attempt2) && all_includes
687 interpret_include_path xs
690 if all_includes then interpret_include_path xs
693 | Ast_c.NonLocal
xs ->
695 Common.fileprefix
(Common.last
xs) =$
= Common.fileprefix
file
697 interpret_include_path xs
699 | Ast_c.Weird
_ -> None
703 +> (fun x
-> (List.rev
(Common.uniq
(List.rev x
)))) (*uniq keeps last*)
705 let rec interpret_dependencies local global
= function
706 Ast_cocci.Dep
s -> List.mem
s local
707 | Ast_cocci.AntiDep
s ->
708 (if !Flag_ctl.steps
!= None
709 then failwith
"steps and ! dependency incompatible");
710 not
(List.mem
s local
)
711 | Ast_cocci.EverDep
s -> List.mem
s global
712 | Ast_cocci.NeverDep
s ->
713 (if !Flag_ctl.steps
!= None
714 then failwith
"steps and ! dependency incompatible");
715 not
(List.mem
s global
)
716 | Ast_cocci.AndDep
(s1
,s2
) ->
717 (interpret_dependencies local global s1
) &&
718 (interpret_dependencies local global s2
)
719 | Ast_cocci.OrDep
(s1
,s2
) ->
720 (interpret_dependencies local global s1
) or
721 (interpret_dependencies local global s2
)
722 | Ast_cocci.NoDep
-> true
723 | Ast_cocci.FailDep
-> false
725 let rec print_dependencies str local global dep
=
726 if !Flag_cocci.show_dependencies
731 let rec loop = function
732 Ast_cocci.Dep
s | Ast_cocci.AntiDep
s ->
733 if not
(List.mem
s !seen)
737 then pr2
(s^
" satisfied")
738 else pr2
(s^
" not satisfied");
741 | Ast_cocci.EverDep
s | Ast_cocci.NeverDep
s ->
742 if not
(List.mem
s !seen)
746 then pr2
(s^
" satisfied")
747 else pr2
(s^
" not satisfied");
750 | Ast_cocci.AndDep
(s1
,s2
) ->
753 | Ast_cocci.OrDep
(s1
,s2
) ->
756 | Ast_cocci.NoDep
-> ()
757 | Ast_cocci.FailDep
-> pr2
"False not satisfied" in
761 (* --------------------------------------------------------------------- *)
762 (* #include relative position in the file *)
763 (* --------------------------------------------------------------------- *)
765 (* compute the set of new prefixes
767 * "a/b/x"; (* in fact it is now a list of string so ["a";"b";"x"] *)
771 * it would give
for the first element
772 * ""; "a"; "a/b"; "a/b/x"
776 * update
: if the
include is inside a ifdef a put nothing
. cf
-test incl
.
777 * this is because we dont want code added inside ifdef
.
780 let compute_new_prefixes xs =
781 xs +> Common.map_withenv
(fun already
xs ->
782 let subdirs_prefixes = Common.inits
xs in
783 let new_first = subdirs_prefixes +> List.filter
(fun x
->
784 not
(List.mem x already
)
793 (* does via side effect on the ref in the Include in Ast_c *)
794 let rec update_include_rel_pos cs
=
795 let only_include = cs
+> Common.map_filter
(fun c
->
797 | Ast_c.CppTop
(Ast_c.Include
{Ast_c.i_include
= ((x
,_));
799 i_is_in_ifdef
= inifdef
}) ->
801 | Ast_c.Weird
_ -> None
810 let (locals
, nonlocals
) =
811 only_include +> Common.partition_either
(fun (c
, aref
) ->
813 | Ast_c.Local x
-> Left
(x
, aref
)
814 | Ast_c.NonLocal x
-> Right
(x
, aref
)
815 | Ast_c.Weird x
-> raise Impossible
818 update_rel_pos_bis locals
;
819 update_rel_pos_bis nonlocals
;
821 and update_rel_pos_bis
xs =
822 let xs'
= List.map fst
xs in
823 let the_first = compute_new_prefixes xs'
in
824 let the_last = List.rev
(compute_new_prefixes (List.rev
xs'
)) in
825 let merged = Common.zip
xs (Common.zip
the_first the_last) in
826 merged +> List.iter
(fun ((x
, aref
), (the_first, the_last)) ->
829 Ast_c.first_of
= the_first;
830 Ast_c.last_of
= the_last;
835 (*****************************************************************************)
836 (* All the information needed around the C elements and Cocci rules *)
837 (*****************************************************************************)
839 type toplevel_c_info
= {
840 ast_c
: Ast_c.toplevel
; (* contain refs so can be modified *)
841 tokens_c
: Parser_c.token list
;
844 flow
: Control_flow_c.cflow
option; (* it's the "fixed" flow *)
847 env_typing_before
: TAC.environment
;
848 env_typing_after
: TAC.environment
;
850 was_modified
: bool ref;
852 all_typedefs
: (string, Lexer_parser.identkind
) Common.scoped_h_env
;
853 all_macros
: (string, Cpp_token_c.define_def
) Hashtbl.t
;
860 dependencies
: Ast_cocci.dependency
;
861 used_after
: Ast_cocci.meta_name list
;
863 was_matched
: bool ref;
866 type toplevel_cocci_info_script_rule
= {
869 (Ast_cocci.script_meta_name
* Ast_cocci.meta_name
*
870 Ast_cocci.metavar
) list
*
871 Ast_cocci.meta_name list
(*fresh vars*) *
875 scr_rule_info
: rule_info
;
878 type toplevel_cocci_info_cocci_rule
= {
879 ctl
: Asttoctl2.top_formula
* (CCI.pred list list
);
880 metavars
: Ast_cocci.metavar list
;
881 ast_rule
: Ast_cocci.rule
;
882 isexp
: bool; (* true if + code is an exp, only for Flag.make_hrule *)
884 (* There are also some hardcoded rule names in parse_cocci.ml:
885 * let reserved_names = ["all";"optional_storage";"optional_qualifier"]
887 dropped_isos
: string list
;
888 free_vars
: Ast_cocci.meta_name list
;
889 negated_pos_vars
: Ast_cocci.meta_name list
;
890 positions
: Ast_cocci.meta_name list
;
892 ruletype
: Ast_cocci.ruletype
;
894 rule_info
: rule_info
;
897 type toplevel_cocci_info
=
898 ScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
899 | InitialScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
900 | FinalScriptRuleCocciInfo
of toplevel_cocci_info_script_rule
901 | CocciRuleCocciInfo
of toplevel_cocci_info_cocci_rule
903 type cocci_info
= toplevel_cocci_info list
* string list
option (* tokens *)
905 type kind_file
= Header
| Source
909 was_modified_once
: bool ref;
910 asts
: toplevel_c_info list
;
915 let g_contain_typedmetavar = ref false
918 let last_env_toplevel_c_info xs =
919 (Common.last
xs).env_typing_after
921 let concat_headers_and_c (ccs
: file_info list
)
922 : (toplevel_c_info
* string) list
=
923 (List.concat
(ccs
+> List.map
(fun x
->
924 x
.asts
+> List.map
(fun x'
->
927 let for_unparser xs =
928 xs +> List.map
(fun x
->
929 (x
.ast_c
, (x
.fullstring
, x
.tokens_c
)), Unparse_c.PPviastr
932 let gen_pdf_graph () =
933 (Ctl_engine.get_graph_files
()) +> List.iter
(fun outfile
->
934 Printf.printf
"Generation of %s%!" outfile
;
935 let filename_stack = Ctl_engine.get_graph_comp_files outfile
in
936 List.iter
(fun filename
->
937 ignore
(Unix.system
("dot " ^ filename ^
" -Tpdf -o " ^ filename ^
".pdf;"))
939 let (head
,tail
) = (List.hd
filename_stack, List.tl
filename_stack) in
940 ignore
(Unix.system
("cp " ^ head ^
".pdf " ^ outfile ^
".pdf;"));
941 tail
+> List.iter
(fun filename
->
942 ignore
(Unix.system
("mv " ^ outfile ^
".pdf /tmp/tmp.pdf;"));
943 ignore
(Unix.system
("pdftk " ^ filename ^
".pdf /tmp/tmp.pdf cat output " ^ outfile ^
".pdf"));
945 ignore
(Unix.system
("rm /tmp/tmp.pdf;"));
946 List.iter
(fun filename
->
947 ignore
(Unix.system
("rm " ^ filename ^
" " ^ filename ^
".pdf;"))
949 Printf.printf
" - Done\n")
951 let local_python_code =
952 "from coccinelle import *\n"
955 "import coccinelle\n"^
957 "import coccilib.org\n"^
958 "import coccilib.report\n" ^
962 let make_init lang code rule_info
=
965 scr_ast_rule
= (lang
, mv, [], code
);
967 script_code
= (if lang
= "python" then python_code else "") ^code
;
968 scr_rule_info
= rule_info
;
971 (* --------------------------------------------------------------------- *)
972 let prepare_cocci ctls free_var_lists negated_pos_lists
973 (ua
,fua
,fuas
) positions_list metavars astcocci
=
975 let gathered = Common.index_list_1
976 (zip
(zip
(zip
(zip
(zip
(zip
(zip
(zip
ctls metavars
) astcocci
)
978 negated_pos_lists
) ua
) fua
) fuas
) positions_list
)
981 (fun (((((((((ctl_toplevel_list
,metavars
),ast
),free_var_list
),
982 negated_pos_list
),ua
),fua
),fuas
),positions_list
),rulenb
) ->
984 let build_rule_info rulename deps
=
985 {rulename
= rulename
;
987 used_after
= (List.hd ua
) @ (List.hd fua
);
989 was_matched
= ref false;} in
991 let is_script_rule r
=
993 Ast_cocci.ScriptRule
_
994 | Ast_cocci.InitialScriptRule
_ | Ast_cocci.FinalScriptRule
_ -> true
997 if not
(List.length ctl_toplevel_list
=|= 1) && not
(is_script_rule ast
)
998 then failwith
"not handling multiple minirules";
1001 Ast_cocci.ScriptRule
(name,lang
,deps
,mv,script_vars
,code
) ->
1004 scr_ast_rule
= (lang
, mv, script_vars
, code
);
1007 scr_rule_info
= build_rule_info name deps
;
1009 in ScriptRuleCocciInfo
r
1010 | Ast_cocci.InitialScriptRule
(name,lang
,deps
,code
) ->
1011 let r = make_init lang code
(build_rule_info name deps
) in
1012 InitialScriptRuleCocciInfo
r
1013 | Ast_cocci.FinalScriptRule
(name,lang
,deps
,code
) ->
1017 scr_ast_rule
= (lang
, mv, [], code
);
1020 scr_rule_info
= build_rule_info name deps
;
1022 in FinalScriptRuleCocciInfo
r
1023 | Ast_cocci.CocciRule
1024 (rulename
,(dependencies
,dropped_isos
,z
),restast
,isexp
,ruletype
) ->
1025 CocciRuleCocciInfo
(
1027 ctl
= List.hd ctl_toplevel_list
;
1028 metavars
= metavars
;
1030 isexp
= List.hd isexp
;
1031 dropped_isos
= dropped_isos
;
1032 free_vars
= List.hd free_var_list
;
1033 negated_pos_vars
= List.hd negated_pos_list
;
1034 positions
= List.hd positions_list
;
1035 ruletype
= ruletype
;
1036 rule_info
= build_rule_info rulename dependencies
;
1040 (* --------------------------------------------------------------------- *)
1042 let build_info_program (cprogram
,typedefs
,macros
) env
=
1044 let (cs
, parseinfos
) =
1045 Common.unzip cprogram
in
1048 parseinfos
+> List.map
(fun (s,toks
) -> toks
) +> List.flatten
in
1050 (* I use cs' but really annotate_xxx work by doing side effects on cs *)
1052 Comment_annotater_c.annotate_program
alltoks cs in
1055 Type_annoter_c.annotate_program env
(*!g_contain_typedmetavar*) cs'
1058 zip
cs_with_envs parseinfos
+> List.map
(fun ((c
, (enva
,envb
)), parseinfo
)->
1059 let (fullstr
, tokens) = parseinfo
in
1062 ast_to_flow_with_error_messages c
+>
1063 Common.map_option
(fun flow ->
1064 let flow = Ast_to_flow.annotate_loop_nodes
flow in
1066 (* remove the fake nodes for julia *)
1067 let fixed_flow = CCI.fix_flow_ctl
flow in
1069 if !Flag_cocci.show_flow
then print_flow fixed_flow;
1070 if !Flag_cocci.show_before_fixed_flow
then print_flow flow;
1077 ast_c
= c
; (* contain refs so can be modified *)
1079 fullstring
= fullstr
;
1083 contain_loop = contain_loop flow;
1085 env_typing_before
= enva
;
1086 env_typing_after
= envb
;
1088 was_modified
= ref false;
1090 all_typedefs
= typedefs
;
1091 all_macros
= macros
;
1097 (* Optimisation. Try not unparse/reparse the whole file when have modifs *)
1098 let rebuild_info_program cs file isexp
=
1099 cs +> List.map
(fun c
->
1100 if !(c
.was_modified
)
1102 let file = Common.new_temp_file
"cocci_small_output" ".c" in
1104 [(c
.ast_c
, (c
.fullstring
, c
.tokens_c
)), Unparse_c.PPnormal
]
1107 (* Common.command2 ("cat " ^ file); *)
1108 let cprogram = cprogram_of_file c
.all_typedefs c
.all_macros
file in
1109 let xs = build_info_program cprogram c
.env_typing_before
in
1111 (* TODO: assert env has not changed,
1112 * if yes then must also reparse what follows even if not modified.
1113 * Do that only if contain_typedmetavar of course, so good opti.
1115 (* Common.list_init xs *) (* get rid of the FinalDef *)
1121 let rebuild_info_c_and_headers ccs isexp
=
1122 ccs
+> List.iter
(fun c_or_h
->
1123 if c_or_h
.asts
+> List.exists
(fun c
-> !(c
.was_modified
))
1124 then c_or_h
.was_modified_once
:= true;
1126 ccs
+> List.map
(fun c_or_h
->
1129 rebuild_info_program c_or_h
.asts c_or_h
.full_fname isexp
}
1132 let rec prepare_h seen env hpath choose_includes
: file_info list
=
1133 if not
(Common.lfile_exists hpath
)
1136 pr2_once
("TYPE: header " ^ hpath ^
" not found");
1141 let h_cs = cprogram_of_file_cached hpath
in
1142 let local_includes =
1143 if choose_includes
=*= Flag_cocci.I_REALLY_ALL_INCLUDES
1146 (function x
-> not
(List.mem x
!seen))
1147 (includes_to_parse
[(hpath
,h_cs)] choose_includes
)
1149 seen := local_includes @ !seen;
1152 (List.map
(function x
-> prepare_h seen env x choose_includes
)
1154 let info_h_cs = build_info_program h_cs !env
in
1158 else last_env_toplevel_c_info info_h_cs;
1161 fname
= Common.basename hpath
;
1164 was_modified_once
= ref false;
1170 let prepare_c files choose_includes
: file_info list
=
1171 let cprograms = List.map
cprogram_of_file_cached files
in
1172 let includes = includes_to_parse
(zip files
cprograms) choose_includes
in
1173 let seen = ref includes in
1175 (* todo?: may not be good to first have all the headers and then all the c *)
1176 let env = ref !TAC.initial_env
in
1180 List.map
(function hpath
-> prepare_h seen env hpath choose_includes
) +>
1184 (zip files
cprograms) +>
1186 (function (file, cprogram) ->
1187 (* todo?: don't update env ? *)
1188 let cs = build_info_program cprogram !env in
1189 (* we do that only for the c, not for the h *)
1190 ignore
(update_include_rel_pos (cs +> List.map
(fun x
-> x
.ast_c
)));
1192 fname
= Common.basename
file;
1195 was_modified_once
= ref false;
1202 (*****************************************************************************)
1203 (* Manage environments as they are being built up *)
1204 (*****************************************************************************)
1206 let init_env _ = Hashtbl.create
101
1208 let update_env env v i
= Hashtbl.replace
env v i
; env
1210 (* know that there are no conflicts *)
1211 let safe_update_env env v i
= Hashtbl.add
env v i
; env
1214 List.sort compare
(Hashtbl.fold
(fun k v rest
-> (k
,v
) :: rest
) env [])
1216 (*****************************************************************************)
1217 (* Processing the ctls and toplevel C elements *)
1218 (*****************************************************************************)
1220 (* The main algorithm =~
1221 * The algorithm is roughly:
1222 * for_all ctl rules in SP
1223 * for_all minirule in rule (no more)
1224 * for_all binding (computed during previous phase)
1225 * for_all C elements
1226 * match control flow of function vs minirule
1227 * with the binding and update the set of possible
1228 * bindings, and returned the possibly modified function.
1229 * pretty print modified C elements and reparse it.
1232 * On ne prends que les newbinding ou returned_any_state est vrai.
1233 * Si ca ne donne rien, on prends ce qu'il y avait au depart.
1234 * Mais au nouveau depart de quoi ?
1235 * - si ca donne rien apres avoir traité toutes les fonctions avec ce binding ?
1236 * - ou alors si ca donne rien, apres avoir traité toutes les fonctions
1237 * avec tous les bindings du round d'avant ?
1239 * Julia pense qu'il faut prendre la premiere solution.
1240 * Example: on a deux environnements candidats, E1 et E2 apres avoir traité
1241 * la regle ctl 1. On arrive sur la regle ctl 2.
1242 * E1 ne donne rien pour la regle 2, on garde quand meme E1 pour la regle 3.
1243 * E2 donne un match a un endroit et rend E2' alors on utilise ca pour
1246 * I have not to look at used_after_list to decide to restart from
1247 * scratch. I just need to look if the binding list is empty.
1248 * Indeed, let's suppose that a SP have 3 regions/rules. If we
1249 * don't find a match for the first region, then if this first
1250 * region does not bind metavariable used after, that is if
1251 * used_after_list is empty, then mysat(), even if does not find a
1252 * match, will return a Left, with an empty transformation_info,
1253 * and so current_binding will grow. On the contrary if the first
1254 * region must bind some metavariables used after, and that we
1255 * dont find any such region, then mysat() will returns lots of
1256 * Right, and current_binding will not grow, and so we will have
1257 * an empty list of binding, and we will catch such a case.
1259 * opti: julia says that because the binding is
1260 * determined by the used_after_list, the items in the list
1261 * are kind of sorted, so could optimise the insert_set operations.
1265 (* r(ule), c(element in C code), e(nvironment) *)
1267 let merge_env new_e old_e
=
1269 (function (e
,rules
) ->
1270 let _ = update_env old_e e rules
in ()) new_e
;
1273 let contains_binding e
(_,(r,m
),_) =
1275 let _ = List.find
(function ((re
, rm
), _) -> r =*= re
&& m
=$
= rm
) e
in
1277 with Not_found
-> false
1281 let python_application mv ve script_vars
r =
1285 ((Some x
,None
),y
,z
) -> (x
,y
,z
)
1288 (Printf.sprintf
"unexpected ast metavar in rule %s"
1289 r.scr_rule_info
.rulename
))
1292 Pycocci.build_classes
(List.map
(function (x
,y
) -> x
) ve
);
1293 Pycocci.construct_variables
mv ve
;
1294 Pycocci.construct_script_variables script_vars
;
1295 let _ = Pycocci.pyrun_simplestring
(local_python_code ^
r.script_code
) in
1298 else if !Pycocci.inc_match
1299 then Some
(Pycocci.retrieve_script_variables script_vars
)
1301 with Pycocci.Pycocciexception
->
1302 (pr2
("Failure in " ^
r.scr_rule_info
.rulename
);
1303 raise
Pycocci.Pycocciexception
)
1305 let ocaml_application mv ve script_vars
r =
1308 Run_ocamlcocci.run
mv ve script_vars
1309 r.scr_rule_info
.rulename
r.script_code
in
1312 else if !Coccilib.inc_match
1313 then Some
script_vals
1315 with e
-> (pr2
("Failure in " ^
r.scr_rule_info
.rulename
); raise e
)
1317 (* returns Left in case of dependency failure, Right otherwise *)
1318 let apply_script_rule r cache newes e rules_that_have_matched
1319 rules_that_have_ever_matched script_application
=
1320 Common.profile_code
r.language
(fun () ->
1321 show_or_not_scr_rule_name r.scr_rule_info
.ruleid
;
1322 if not
(interpret_dependencies rules_that_have_matched
1323 !rules_that_have_ever_matched
r.scr_rule_info
.dependencies
)
1326 print_dependencies "dependencies for script not satisfied:"
1327 rules_that_have_matched
1328 !rules_that_have_ever_matched
r.scr_rule_info
.dependencies
;
1329 show_or_not_binding "in environment" e
;
1330 (cache
, safe_update_env newes e rules_that_have_matched
)
1334 let (_, mv, script_vars
, _) = r.scr_ast_rule
in
1336 (List.map
(function (n
,v
) -> (("virtual",n
),Ast_c.MetaIdVal
(v
,[])))
1337 !Flag.defined_virtual_env
) @ e
in
1338 let not_bound x
= not
(contains_binding ve x
) in
1339 (match List.filter
not_bound mv with
1341 let relevant_bindings =
1343 (function ((re
,rm
),_) ->
1344 List.exists
(function (_,(r,m
),_) -> r =*= re
&& m
=$
= rm
) mv)
1347 match List.assoc
relevant_bindings cache
with
1348 None
-> (cache
,newes
)
1349 | Some
script_vals ->
1351 "dependencies for script satisfied, but cached:"
1352 rules_that_have_matched
1353 !rules_that_have_ever_matched
1354 r.scr_rule_info
.dependencies
;
1355 show_or_not_binding "in" e
;
1356 (* env might be bigger than what was cached against, so have to
1357 merge with newes anyway *)
1358 let new_e = (List.combine script_vars
script_vals) @ e
in
1362 (fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1363 (cache
,update_env newes
new_e rules_that_have_matched
)
1366 print_dependencies "dependencies for script satisfied:"
1367 rules_that_have_matched
1368 !rules_that_have_ever_matched
1369 r.scr_rule_info
.dependencies
;
1370 show_or_not_binding "in" e
;
1371 match script_application
mv ve script_vars
r with
1373 (* failure means we should drop e, no new bindings *)
1374 (((relevant_bindings,None
) :: cache
), newes
)
1375 | Some
script_vals ->
1377 List.map
(function x
-> Ast_c.MetaIdVal
(x
,[]))
1379 let new_e = (List.combine script_vars
script_vals) @ e
in
1383 (fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1384 r.scr_rule_info
.was_matched
:= true;
1385 (((relevant_bindings,Some
script_vals) :: cache
),
1386 update_env newes
new_e
1387 (r.scr_rule_info
.rulename
:: rules_that_have_matched
))
1390 (if !Flag_cocci.show_dependencies
1392 let m2c (_,(r,x
),_) = r^
"."^x
in
1393 pr2
(Printf.sprintf
"script not applied: %s not bound"
1394 (String.concat
", " (List.map
m2c unbound
))));
1397 List.filter
(fun (s,v
) -> List.mem
s r.scr_rule_info
.used_after
) in
1398 (cache
, update_env newes
e rules_that_have_matched
))
1401 let rec apply_cocci_rule r rules_that_have_ever_matched es
1402 (ccs
:file_info list
ref) =
1403 Common.profile_code
r.rule_info
.rulename
(fun () ->
1404 show_or_not_rule_name r.ast_rule
r.rule_info
.ruleid
;
1405 show_or_not_ctl_text r.ctl
r.ast_rule
r.rule_info
.ruleid
;
1407 let reorganized_env =
1408 reassociate_positions
r.free_vars
r.negated_pos_vars
!es
in
1410 (* looping over the environments *)
1411 let (_,newes
(* envs for next round/rule *)) =
1413 (function (cache
,newes
) ->
1414 function ((e,rules_that_have_matched
),relevant_bindings) ->
1415 if not
(interpret_dependencies rules_that_have_matched
1416 !rules_that_have_ever_matched
1417 r.rule_info
.dependencies
)
1421 ("dependencies for rule "^
r.rule_info
.rulename^
1423 rules_that_have_matched
1424 !rules_that_have_ever_matched
r.rule_info
.dependencies
;
1425 show_or_not_binding "in environment" e;
1430 (fun (s,v
) -> List.mem
s r.rule_info
.used_after
))
1431 rules_that_have_matched
)
1435 try List.assoc
relevant_bindings cache
1439 ("dependencies for rule "^
r.rule_info
.rulename^
1441 rules_that_have_matched
1442 !rules_that_have_ever_matched
1443 r.rule_info
.dependencies
;
1444 show_or_not_binding "in" e;
1445 show_or_not_binding "relevant in" relevant_bindings;
1447 (* applying the rule *)
1448 (match r.ruletype
with
1450 (* looping over the functions and toplevel elements in
1453 (concat_headers_and_c !ccs
+>
1454 List.fold_left
(fun children_e
(c
,f) ->
1457 (* does also some side effects on c and r *)
1459 process_a_ctl_a_env_a_toplevel
r
1460 relevant_bindings c
f in
1461 match processed with
1462 | None
-> children_e
1463 | Some newbindings
->
1466 (fun children_e newbinding
->
1467 if List.mem newbinding children_e
1469 else newbinding
:: children_e
)
1473 | Ast_cocci.Generated
->
1474 process_a_generated_a_env_a_toplevel
r
1475 relevant_bindings !ccs
;
1478 let old_bindings_to_keep =
1482 (fun (s,v
) -> List.mem
s r.rule_info
.used_after
)) in
1484 if null
new_bindings
1487 (*use the old bindings, specialized to the used_after_list*)
1488 if !Flag_ctl.partial_match
1491 "Empty list of bindings, I will restart from old env\n";
1492 [(old_bindings_to_keep,rules_that_have_matched
)]
1495 (* combine the new bindings with the old ones, and
1496 specialize to the used_after_list *)
1497 let old_variables = List.map fst
old_bindings_to_keep in
1498 (* have to explicitly discard the inherited variables
1499 because we want the inherited value of the positions
1500 variables not the extended one created by
1501 reassociate_positions. want to reassociate freshly
1502 according to the free variables of each rule. *)
1503 let new_bindings_to_add =
1509 (* see comment before combine_pos *)
1510 (s,Ast_c.MetaPosValList
[]) -> false
1512 List.mem
s r.rule_info
.used_after
&&
1513 not
(List.mem
s old_variables)))) in
1515 (function new_binding_to_add
->
1518 old_bindings_to_keep new_binding_to_add
),
1519 r.rule_info
.rulename
::rules_that_have_matched
))
1520 new_bindings_to_add in
1521 ((relevant_bindings,new_bindings)::cache
,
1522 Common.profile_code
"merge_env" (function _ ->
1523 merge_env new_e newes
)))
1524 ([],init_env()) reorganized_env in (* end iter es *)
1525 if !(r.rule_info
.was_matched
)
1526 then Common.push2
r.rule_info
.rulename rules_that_have_ever_matched
;
1528 es
:= end_env newes
;
1530 (* apply the tagged modifs and reparse *)
1531 if not
!Flag.sgrep_mode2
1532 then ccs
:= rebuild_info_c_and_headers !ccs
r.isexp
)
1534 and reassociate_positions free_vars negated_pos_vars envs
=
1535 (* issues: isolate the bindings that are relevant to a given rule.
1536 separate out the position variables
1537 associate all of the position variables for a given set of relevant
1538 normal variable bindings with each set of relevant normal variable
1539 bindings. Goal: if eg if@p (E) matches in two places, then both inherited
1540 occurrences of E should see both bindings of p, not just its own.
1541 Otherwise, a position constraint for something that matches in two
1542 places will never be useful, because the position can always be
1543 different from the other one. *)
1547 List.filter
(function (x
,_) -> List.mem x free_vars
) e)
1549 let splitted_relevant =
1550 (* separate the relevant variables into the non-position ones and the
1555 (function (non_pos
,pos
) ->
1556 function (v
,_) as x
->
1557 if List.mem v negated_pos_vars
1558 then (non_pos
,x
::pos
)
1559 else (x
::non_pos
,pos
))
1562 let splitted_relevant =
1564 (function (non_pos
,pos
) ->
1565 (List.sort compare non_pos
,List.sort compare pos
))
1566 splitted_relevant in
1569 (function non_pos
->
1571 if List.mem np non_pos
then non_pos
else np
::non_pos
)
1572 [] splitted_relevant in
1573 let extended_relevant =
1574 (* extend the position variables with the values found at other identical
1575 variable bindings *)
1577 (function non_pos
->
1580 (function (other_non_pos
,other_pos
) ->
1581 (* do we want equal? or just somehow compatible? eg non_pos
1582 binds only E, but other_non_pos binds both E and E1 *)
1583 non_pos
=*= other_non_pos
)
1584 splitted_relevant in
1588 (combine_pos negated_pos_vars
1589 (List.map
(function (_,x
) -> x
) others)))))
1592 (List.map
(function (non_pos
,_) -> List.assoc non_pos
extended_relevant)
1595 (* If the negated posvar is not bound at all, this function will
1596 nevertheless bind it to []. If we get rid of these bindings, then the
1597 matching of the term the position variable with the constraints will fail
1598 because some variables are unbound. So we let the binding be [] and then
1599 we will have to clean these up afterwards. This should be the only way
1600 that a position variable can have an empty binding. *)
1601 and combine_pos negated_pos_vars
others =
1607 (function positions ->
1608 function other_list
->
1610 match List.assoc posvar other_list
with
1611 Ast_c.MetaPosValList l1
->
1612 Common.union_set l1
positions
1613 | _ -> failwith
"bad value for a position variable"
1614 with Not_found
-> positions)
1616 (posvar
,Ast_c.MetaPosValList
positions))
1619 and process_a_generated_a_env_a_toplevel2
r env = function
1624 (rule
,_) when rule
=$
= r.rule_info
.rulename
-> false
1625 | (_,"ARGS") -> false
1628 let env_domain = List.map
(function (nm
,vl
) -> nm
) env in
1632 let (rl
,_) = Ast_cocci.get_meta_name md
in rl
=$
= r.rule_info
.rulename
)
1634 if Common.include_set
free_vars env_domain
1635 then Unparse_hrule.pp_rule
metavars r.ast_rule
env cfile.full_fname
1636 | _ -> failwith
"multiple files not supported"
1638 and process_a_generated_a_env_a_toplevel rule
env ccs
=
1639 Common.profile_code
"process_a_ctl_a_env_a_toplevel"
1640 (fun () -> process_a_generated_a_env_a_toplevel2 rule
env ccs
)
1642 (* does side effects on C ast and on Cocci info rule *)
1643 and process_a_ctl_a_env_a_toplevel2
r e c
f =
1644 indent_do
(fun () ->
1645 show_or_not_celem "trying" c
.ast_c
;
1646 Flag.currentfile
:= Some
(f ^
":" ^
get_celem c
.ast_c
);
1647 match (r.ctl
,c
.ast_c
) with
1648 ((Asttoctl2.NONDECL ctl
,t
),Ast_c.Declaration
_) -> None
1649 | ((Asttoctl2.NONDECL ctl
,t
), _)
1650 | ((Asttoctl2.CODE ctl
,t
), _) ->
1651 let ctl = (ctl,t
) in (* ctl and other info *)
1652 let (trans_info, returned_any_states
, inherited_bindings
, newbindings
) =
1653 Common.save_excursion
Flag_ctl.loop_in_src_code
(fun () ->
1654 Flag_ctl.loop_in_src_code
:=
1655 !Flag_ctl.loop_in_src_code
||c
.contain_loop;
1657 (***************************************)
1658 (* !Main point! The call to the engine *)
1659 (***************************************)
1661 CCI.model_for_ctl
r.dropped_isos
(Common.some c
.flow) e
1662 in CCI.mysat
model_ctl ctl
1663 (r.rule_info
.rulename
, r.rule_info
.used_after
, e))
1665 if not returned_any_states
1669 show_or_not_celem "found match in" c
.ast_c
;
1670 show_or_not_trans_info trans_info;
1671 List.iter
(show_or_not_binding "out") newbindings
;
1673 r.rule_info
.was_matched
:= true;
1675 if not
(null
trans_info) &&
1676 not
(!Flag.sgrep_mode2
&& not
!Flag_cocci.show_diff
)
1679 c
.was_modified
:= true;
1681 (* les "more than one var in a decl" et "already tagged token"
1682 * font crasher coccinelle. Si on a 5 fichiers, donc on a 5
1683 * failed. Le try limite le scope des crashes pendant la
1684 * trasformation au fichier concerne. *)
1686 (* modify ast via side effect *)
1688 (Transformation_c.transform
r.rule_info
.rulename
1690 inherited_bindings
trans_info (Common.some c
.flow));
1691 with Timeout
-> raise Timeout
| UnixExit i
-> raise
(UnixExit i
)
1694 Some
(List.map
(function x
-> x
@inherited_bindings
) newbindings
)
1698 and process_a_ctl_a_env_a_toplevel a b c
f=
1699 Common.profile_code
"process_a_ctl_a_env_a_toplevel"
1700 (fun () -> process_a_ctl_a_env_a_toplevel2 a b c
f)
1703 let rec bigloop2 rs
(ccs
: file_info list
) =
1704 let init_es = [(Ast_c.emptyMetavarsBinding
,[])] in
1705 let es = ref init_es in
1706 let ccs = ref ccs in
1707 let rules_that_have_ever_matched = ref [] in
1711 (* looping over the rules *)
1712 rs
+> List.iter
(fun r ->
1714 InitialScriptRuleCocciInfo
r | FinalScriptRuleCocciInfo
r -> ()
1715 | ScriptRuleCocciInfo
r ->
1716 if !Flag_cocci.show_ctl_text
then begin
1717 Common.pr_xxxxxxxxxxxxxxxxx
();
1718 pr
("script: " ^
r.language
);
1719 Common.pr_xxxxxxxxxxxxxxxxx
();
1721 adjust_pp_with_indent
(fun () ->
1722 Format.force_newline
();
1723 let (l,mv,script_vars
,code
) = r.scr_ast_rule
in
1724 let nm = r.scr_rule_info
.rulename
in
1725 let deps = r.scr_rule_info
.dependencies
in
1726 Pretty_print_cocci.unparse
1727 (Ast_cocci.ScriptRule
(nm,l,deps,mv,script_vars
,code
)));
1730 (*pr2 (List.hd(cmd_to_list "free -m | grep Mem"));*)
1731 if !Flag.show_misc
then print_endline
"RESULT =";
1735 (function (cache
, newes
) ->
1736 function (e, rules_that_have_matched
) ->
1737 match r.language
with
1739 apply_script_rule r cache newes
e rules_that_have_matched
1740 rules_that_have_ever_matched python_application
1742 apply_script_rule r cache newes
e rules_that_have_matched
1743 rules_that_have_ever_matched ocaml_application
1745 concat_headers_and_c !ccs +> List.iter
(fun (c
,_) ->
1748 Printf.printf
"Flow: %s\r\nFlow!\r\n%!" c
.fullstring
);
1751 Printf.printf
"Unknown language: %s\n" r.language
;
1753 ([],init_env()) !es in
1755 (if !(r.scr_rule_info
.was_matched
)
1757 Common.push2
r.scr_rule_info
.rulename
rules_that_have_ever_matched);
1759 (* just newes can't work, because if one does include_match false
1760 on everything that binds a variable, then nothing is left *)
1762 (if Hashtbl.length newes
= 0 then init_es else end_env newes
)
1763 | CocciRuleCocciInfo
r ->
1764 apply_cocci_rule r rules_that_have_ever_matched
1768 if !Flag.sgrep_mode2
1770 (* sgrep can lead to code that is not parsable, but we must
1771 * still call rebuild_info_c_and_headers to pretty print the
1772 * action (MINUS), so that later the diff will show what was
1773 * matched by sgrep. But we don't want the parsing error message
1774 * hence the following flag setting. So this code propably
1775 * will generate a NotParsedCorrectly for the matched parts
1776 * and the very final pretty print and diff will work
1778 Flag_parsing_c.verbose_parsing
:= false;
1779 ccs := rebuild_info_c_and_headers !ccs false
1781 !ccs (* return final C asts *)
1784 Common.profile_code
"bigloop" (fun () -> bigloop2 a b
)
1786 type init_final
= Initial
| Final
1788 let initial_final_bigloop2 ty rebuild
r =
1789 if !Flag_cocci.show_ctl_text
then
1791 Common.pr_xxxxxxxxxxxxxxxxx
();
1792 pr
((match ty
with Initial
-> "initial" | Final
-> "final") ^
": " ^
1794 Common.pr_xxxxxxxxxxxxxxxxx
();
1796 adjust_pp_with_indent
(fun () ->
1797 Format.force_newline
();
1798 Pretty_print_cocci.unparse
(rebuild
r.scr_ast_rule
r.scr_rule_info
.dependencies
));
1801 match r.language
with
1803 (* include_match makes no sense in an initial or final rule, although
1804 we have no way to prevent it *)
1805 let newes = init_env() in
1806 let _ = apply_script_rule r [] newes [] [] (ref []) python_application in
1808 | "ocaml" when ty
= Initial
-> () (* nothing to do *)
1810 (* include_match makes no sense in an initial or final rule, although
1811 we have no way to prevent it *)
1812 let newes = init_env() in
1813 let _ = apply_script_rule r [] newes [] [] (ref []) ocaml_application in
1816 failwith
("Unknown language for initial/final script: "^
1819 let initial_final_bigloop a b c
=
1820 Common.profile_code
"initial_final_bigloop"
1821 (fun () -> initial_final_bigloop2 a b c
)
1823 (*****************************************************************************)
1824 (* The main functions *)
1825 (*****************************************************************************)
1827 let pre_engine2 (coccifile
, isofile
) =
1828 show_or_not_cocci coccifile isofile
;
1829 Pycocci.set_coccifile coccifile
;
1832 if not
(Common.lfile_exists
isofile)
1834 pr2
("warning: Can't find default iso file: " ^
isofile);
1837 else Some
isofile in
1839 (* useful opti when use -dir *)
1840 let (metavars,astcocci
,
1841 free_var_lists
,negated_pos_lists
,used_after_lists
,
1842 positions_lists
,(toks
,_,_)) = sp_of_file coccifile
isofile in
1844 let ctls = ctls_of_ast astcocci used_after_lists positions_lists
in
1846 g_contain_typedmetavar := sp_contain_typed_metavar astcocci
;
1848 check_macro_in_sp_and_adjust toks
;
1850 show_or_not_ctl_tex astcocci
ctls;
1853 prepare_cocci ctls free_var_lists negated_pos_lists
1854 used_after_lists positions_lists
metavars astcocci
in
1856 let used_languages =
1858 (function languages
->
1860 ScriptRuleCocciInfo
(r) ->
1861 if List.mem
r.language languages
then
1864 r.language
::languages
1869 let rlang = r.language
in
1870 let rname = r.scr_rule_info
.rulename
in
1872 let _ = List.assoc
(rlang,rname) !Iteration.initialization_stack
in
1876 Iteration.initialization_stack
:=
1877 ((rlang,rname),!Flag.defined_virtual_rules
) ::
1878 !Iteration.initialization_stack
;
1879 initial_final_bigloop Initial
1880 (fun (x
,_,_,y
) -> fun deps ->
1881 Ast_cocci.InitialScriptRule
(rname,x
,deps,y
))
1885 let initialized_languages =
1887 (function languages
->
1889 InitialScriptRuleCocciInfo
(r) ->
1890 let rlang = r.language
in
1891 (if List.mem
rlang languages
1892 then failwith
("double initializer found for "^
rlang));
1893 if interpret_dependencies [] [] r.scr_rule_info
.dependencies
1894 then begin runrule r; rlang::languages
end
1899 let uninitialized_languages =
1901 (fun used
-> not
(List.mem used
initialized_languages))
1908 dependencies
= Ast_cocci.NoDep
;
1911 was_matched
= ref false;} in
1912 runrule (make_init lgg
"" rule_info))
1913 uninitialized_languages;
1918 Common.profile_code
"pre_engine" (fun () -> pre_engine2 a
)
1920 let full_engine2 (cocci_infos,toks
) cfiles =
1922 show_or_not_cfiles cfiles;
1924 (* optimisation allowing to launch coccinelle on all the drivers *)
1925 if !Flag_cocci.worth_trying_opt
&& not
(worth_trying cfiles toks
)
1931 pr2
("No matches found for " ^
(Common.join
" " toks
)
1932 ^
"\nSkipping:" ^
(Common.join
" " cfiles)));
1933 cfiles +> List.map
(fun s -> s, None
)
1938 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1939 if !Flag.show_misc
then pr
"let's go";
1940 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1942 if !Flag_cocci.show_binding_in_out
1945 (match !Flag.defined_virtual_rules
with
1947 | l -> pr
(Printf.sprintf
"Defined virtual rules: %s"
1948 (String.concat
" " l)));
1951 pr
(Printf.sprintf
"%s = %s" v vl
))
1952 !Flag.defined_virtual_env
;
1953 Common.pr_xxxxxxxxxxxxxxxxx
()
1956 let choose_includes =
1957 match !Flag_cocci.include_options
with
1958 Flag_cocci.I_UNSPECIFIED
->
1959 if !g_contain_typedmetavar
1960 then Flag_cocci.I_NORMAL_INCLUDES
1961 else Flag_cocci.I_NO_INCLUDES
1963 let c_infos = prepare_c cfiles choose_includes in
1965 (* ! the big loop ! *)
1966 let c_infos'
= bigloop cocci_infos c_infos in
1968 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1969 if !Flag.show_misc
then pr
"Finished";
1970 if !Flag.show_misc
then Common.pr_xxxxxxxxxxxxxxxxx
();
1971 if !Flag_ctl.graphical_trace
then gen_pdf_graph ();
1973 c_infos'
+> List.map
(fun c_or_h
->
1974 if !(c_or_h
.was_modified_once
)
1978 Common.new_temp_file
"cocci-output" ("-" ^ c_or_h
.fname
) in
1980 if c_or_h
.fkind
=*= Header
1981 then pr2
("a header file was modified: " ^ c_or_h
.fname
);
1983 (* and now unparse everything *)
1984 cfile_of_program (for_unparser c_or_h
.asts
) outfile;
1986 show_or_not_diff c_or_h
.fpath
outfile;
1989 if !Flag.sgrep_mode2
then None
else Some
outfile)
1991 else (c_or_h
.fpath
, None
))
1994 let full_engine a b
=
1995 Common.profile_code
"full_engine"
1996 (fun () -> let res = full_engine2 a b
in (*Gc.print_stat stderr; *)res)
1998 let post_engine2 (cocci_infos,_) =
2000 (function ((language
,_),virt_rules
) ->
2001 Flag.defined_virtual_rules
:= virt_rules
;
2004 (function languages
->
2006 FinalScriptRuleCocciInfo
(r) ->
2007 (if r.language
= language
&& List.mem
r.language languages
2008 then failwith
("double finalizer found for "^
r.language
));
2009 initial_final_bigloop Final
2010 (fun (x
,_,_,y
) -> fun deps ->
2011 Ast_cocci.FinalScriptRule
(r.scr_rule_info
.rulename
,
2014 r.language
::languages
2018 !Iteration.initialization_stack
2021 Common.profile_code
"post_engine" (fun () -> post_engine2 a
)
2023 (*****************************************************************************)
2024 (* check duplicate from result of full_engine *)
2025 (*****************************************************************************)
2027 let check_duplicate_modif2 xs =
2028 (* opti: let groups = Common.groupBy (fun (a,resa) (b,resb) -> a =$= b) xs *)
2029 if !Flag_cocci.verbose_cocci
2030 then pr2
("Check duplication for " ^ i_to_s
(List.length
xs) ^
" files");
2032 let groups = Common.group_assoc_bykey_eff
xs in
2033 groups +> Common.map_filter
(fun (file, xs) ->
2035 | [] -> raise Impossible
2036 | [res] -> Some
(file, res)
2040 if not
(List.for_all
(fun res2
-> res2
=*= None
) xs)
2042 pr2
("different modification result for " ^
file);
2045 else Some
(file, None
)
2047 if not
(List.for_all
(fun res2
->
2051 let diff = Common.cmd_to_list
("diff -u -b -B "^
res^
" "^res2
)
2055 pr2
("different modification result for " ^
file);
2058 else Some
(file, Some
res)
2060 let check_duplicate_modif a
=
2061 Common.profile_code
"check_duplicate" (fun () -> check_duplicate_modif2 a
)