| 1 | (* |
| 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. |
| 9 | * |
| 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. |
| 13 | * |
| 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. |
| 18 | * |
| 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/>. |
| 21 | * |
| 22 | * The authors reserve the right to distribute this or future versions of |
| 23 | * Coccinelle under other licenses. |
| 24 | *) |
| 25 | |
| 26 | |
| 27 | # 0 "./cocci.ml" |
| 28 | open Common |
| 29 | |
| 30 | module CCI = Ctlcocci_integration |
| 31 | module TAC = Type_annoter_c |
| 32 | |
| 33 | module Ast_to_flow = Control_flow_c_build |
| 34 | |
| 35 | (*****************************************************************************) |
| 36 | (* This file is a kind of driver. It gathers all the important functions |
| 37 | * from coccinelle in one place. The different entities in coccinelle are: |
| 38 | * - files |
| 39 | * - astc |
| 40 | * - astcocci |
| 41 | * - flow (contain nodes) |
| 42 | * - ctl (contain rule_elems) |
| 43 | * This file contains functions to transform one in another. |
| 44 | *) |
| 45 | (*****************************************************************************) |
| 46 | |
| 47 | (* --------------------------------------------------------------------- *) |
| 48 | (* C related *) |
| 49 | (* --------------------------------------------------------------------- *) |
| 50 | let cprogram_of_file saved_typedefs saved_macros file = |
| 51 | let (program2, _stat) = |
| 52 | Parse_c.parse_c_and_cpp_keep_typedefs |
| 53 | (if !Flag_cocci.use_saved_typedefs then (Some saved_typedefs) else None) |
| 54 | (Some saved_macros) file in |
| 55 | program2 |
| 56 | |
| 57 | let cprogram_of_file_cached file = |
| 58 | let ((program2,typedefs,macros), _stat) = Parse_c.parse_cache file in |
| 59 | if !Flag_cocci.ifdef_to_if |
| 60 | then |
| 61 | let p2 = |
| 62 | program2 +> Parse_c.with_program2 (fun asts -> |
| 63 | Cpp_ast_c.cpp_ifdef_statementize asts |
| 64 | ) in |
| 65 | (p2,typedefs,macros) |
| 66 | else (program2,typedefs,macros) |
| 67 | |
| 68 | let cfile_of_program program2_with_ppmethod outf = |
| 69 | Unparse_c.pp_program program2_with_ppmethod outf |
| 70 | |
| 71 | (* for memoization, contains only one entry, the one for the SP *) |
| 72 | let _hparse = Hashtbl.create 101 |
| 73 | let _h_ocaml_init = Hashtbl.create 101 |
| 74 | let _hctl = Hashtbl.create 101 |
| 75 | |
| 76 | (* --------------------------------------------------------------------- *) |
| 77 | (* Cocci related *) |
| 78 | (* --------------------------------------------------------------------- *) |
| 79 | (* for a given pair (file,iso), only keep an instance for the most recent |
| 80 | virtual rules and virtual_env *) |
| 81 | |
| 82 | let sp_of_file2 file iso = |
| 83 | let redo _ = |
| 84 | let new_code = |
| 85 | let (_,xs,_,_,_,_,_) as res = Parse_cocci.process file iso false in |
| 86 | (* if there is already a compiled ML code, do nothing and use that *) |
| 87 | try let _ = Hashtbl.find _h_ocaml_init (file,iso) in res |
| 88 | with Not_found -> |
| 89 | begin |
| 90 | Hashtbl.add _h_ocaml_init (file,iso) (); |
| 91 | match Prepare_ocamlcocci.prepare file xs with |
| 92 | None -> res |
| 93 | | Some ocaml_script_file -> |
| 94 | (* compile file *) |
| 95 | Prepare_ocamlcocci.load_file ocaml_script_file; |
| 96 | (if not !Common.save_tmp_files |
| 97 | then Prepare_ocamlcocci.clean_file ocaml_script_file); |
| 98 | res |
| 99 | end in |
| 100 | Hashtbl.add _hparse (file,iso) |
| 101 | (!Flag.defined_virtual_rules,!Flag.defined_virtual_env,new_code); |
| 102 | new_code in |
| 103 | try |
| 104 | let (rules,env,code) = Hashtbl.find _hparse (file,iso) in |
| 105 | if rules = !Flag.defined_virtual_rules && env = !Flag.defined_virtual_env |
| 106 | then code |
| 107 | else (Hashtbl.remove _hparse (file,iso); redo()) |
| 108 | with Not_found -> redo() |
| 109 | |
| 110 | let sp_of_file file iso = |
| 111 | Common.profile_code "parse cocci" (fun () -> sp_of_file2 file iso) |
| 112 | |
| 113 | |
| 114 | (* --------------------------------------------------------------------- *) |
| 115 | (* Flow related *) |
| 116 | (* --------------------------------------------------------------------- *) |
| 117 | let print_flow flow = |
| 118 | Ograph_extended.print_ograph_mutable flow "/tmp/test.dot" true |
| 119 | |
| 120 | |
| 121 | let ast_to_flow_with_error_messages2 x = |
| 122 | let flowopt = |
| 123 | try Ast_to_flow.ast_to_control_flow x |
| 124 | with Ast_to_flow.Error x -> |
| 125 | Ast_to_flow.report_error x; |
| 126 | None |
| 127 | in |
| 128 | flowopt +> do_option (fun flow -> |
| 129 | (* This time even if there is a deadcode, we still have a |
| 130 | * flow graph, so I can try the transformation and hope the |
| 131 | * deadcode will not bother us. |
| 132 | *) |
| 133 | try Ast_to_flow.deadcode_detection flow |
| 134 | with Ast_to_flow.Error (Ast_to_flow.DeadCode x) -> |
| 135 | Ast_to_flow.report_error (Ast_to_flow.DeadCode x); |
| 136 | ); |
| 137 | flowopt |
| 138 | let ast_to_flow_with_error_messages a = |
| 139 | Common.profile_code "flow" (fun () -> ast_to_flow_with_error_messages2 a) |
| 140 | |
| 141 | |
| 142 | (* --------------------------------------------------------------------- *) |
| 143 | (* Ctl related *) |
| 144 | (* --------------------------------------------------------------------- *) |
| 145 | |
| 146 | let ctls_of_ast2 ast (ua,fua,fuas) pos = |
| 147 | List.map2 |
| 148 | (function ast -> function (ua,(fua,(fuas,pos))) -> |
| 149 | List.combine |
| 150 | (if !Flag_cocci.popl |
| 151 | then Popl.popl ast |
| 152 | else Asttoctl2.asttoctl ast (ua,fua,fuas) pos) |
| 153 | (Asttomember.asttomember ast ua)) |
| 154 | ast (List.combine ua (List.combine fua (List.combine fuas pos))) |
| 155 | |
| 156 | let ctls_of_ast ast ua pl = |
| 157 | Common.profile_code "asttoctl2" (fun () -> ctls_of_ast2 ast ua pl) |
| 158 | |
| 159 | (*****************************************************************************) |
| 160 | (* Some debugging functions *) |
| 161 | (*****************************************************************************) |
| 162 | |
| 163 | (* the inputs *) |
| 164 | |
| 165 | let show_or_not_cfile2 cfile = |
| 166 | if !Flag_cocci.show_c then begin |
| 167 | Common.pr2_xxxxxxxxxxxxxxxxx (); |
| 168 | pr2 ("processing C file: " ^ cfile); |
| 169 | Common.pr2_xxxxxxxxxxxxxxxxx (); |
| 170 | Common.command2 ("cat " ^ cfile); |
| 171 | end |
| 172 | let show_or_not_cfile a = |
| 173 | Common.profile_code "show_xxx" (fun () -> show_or_not_cfile2 a) |
| 174 | |
| 175 | let show_or_not_cfiles cfiles = List.iter show_or_not_cfile cfiles |
| 176 | |
| 177 | |
| 178 | let show_or_not_cocci2 coccifile isofile = |
| 179 | if !Flag_cocci.show_cocci then begin |
| 180 | Common.pr2_xxxxxxxxxxxxxxxxx (); |
| 181 | pr2 ("processing semantic patch file: " ^ coccifile); |
| 182 | isofile +> (fun s -> pr2 ("with isos from: " ^ s)); |
| 183 | Common.pr2_xxxxxxxxxxxxxxxxx (); |
| 184 | Common.command2 ("cat " ^ coccifile); |
| 185 | pr2 ""; |
| 186 | end |
| 187 | let show_or_not_cocci a b = |
| 188 | Common.profile_code "show_xxx" (fun () -> show_or_not_cocci2 a b) |
| 189 | |
| 190 | (* ---------------------------------------------------------------------- *) |
| 191 | (* the output *) |
| 192 | |
| 193 | let fix_sgrep_diffs l = |
| 194 | let l = |
| 195 | List.filter (function s -> (s =~ "^\\+\\+\\+") || not (s =~ "^\\+")) l in |
| 196 | let l = List.rev l in |
| 197 | (* adjust second number for + code *) |
| 198 | let rec loop1 n = function |
| 199 | [] -> [] |
| 200 | | s::ss -> |
| 201 | if s =~ "^-" && not(s =~ "^---") |
| 202 | then s :: loop1 (n+1) ss |
| 203 | else if s =~ "^@@" |
| 204 | then |
| 205 | (match Str.split (Str.regexp " ") s with |
| 206 | bef::min::pl::aft -> |
| 207 | let (n1,n2) = |
| 208 | match Str.split (Str.regexp ",") pl with |
| 209 | [n1;n2] -> (n1,n2) |
| 210 | | [n1] -> (n1,"1") |
| 211 | | _ -> failwith "bad + line information" in |
| 212 | let n2 = int_of_string n2 in |
| 213 | (Printf.sprintf "%s %s %s,%d %s" bef min n1 (n2-n) |
| 214 | (String.concat " " aft)) |
| 215 | :: loop1 0 ss |
| 216 | | _ -> failwith "bad @@ information") |
| 217 | else s :: loop1 n ss in |
| 218 | let rec loop2 n = function |
| 219 | [] -> [] |
| 220 | | s::ss -> |
| 221 | if s =~ "^---" |
| 222 | then s :: loop2 0 ss |
| 223 | else if s =~ "^@@" |
| 224 | then |
| 225 | (match Str.split (Str.regexp " ") s with |
| 226 | bef::min::pl::aft -> |
| 227 | let (m2,n1,n2) = |
| 228 | match (Str.split (Str.regexp ",") min, |
| 229 | Str.split (Str.regexp ",") pl) with |
| 230 | ([_;m2],[n1;n2]) -> (m2,n1,n2) |
| 231 | | ([_],[n1;n2]) -> ("1",n1,n2) |
| 232 | | ([_;m2],[n1]) -> (m2,n1,"1") |
| 233 | | ([_],[n1]) -> ("1",n1,"1") |
| 234 | | _ -> failwith "bad -/+ line information" in |
| 235 | let n1 = |
| 236 | int_of_string (String.sub n1 1 ((String.length n1)-1)) in |
| 237 | let m2 = int_of_string m2 in |
| 238 | let n2 = int_of_string n2 in |
| 239 | (Printf.sprintf "%s %s +%d,%d %s" bef min (n1-n) n2 |
| 240 | (String.concat " " aft)) |
| 241 | :: loop2 (n+(m2-n2)) ss |
| 242 | | _ -> failwith "bad @@ information") |
| 243 | else s :: loop2 n ss in |
| 244 | loop2 0 (List.rev (loop1 0 l)) |
| 245 | |
| 246 | let normalize_path file = |
| 247 | let fullpath = |
| 248 | if String.get file 0 = '/' then file else (Sys.getcwd()) ^ "/" ^ file in |
| 249 | let elements = Str.split_delim (Str.regexp "/") fullpath in |
| 250 | let rec loop prev = function |
| 251 | [] -> String.concat "/" (List.rev prev) |
| 252 | | "." :: rest -> loop prev rest |
| 253 | | ".." :: rest -> |
| 254 | (match prev with |
| 255 | x::xs -> loop xs rest |
| 256 | | _ -> failwith "bad path") |
| 257 | | x::rest -> loop (x::prev) rest in |
| 258 | loop [] elements |
| 259 | |
| 260 | let generated_patches = Hashtbl.create(100) |
| 261 | |
| 262 | let show_or_not_diff2 cfile outfile = |
| 263 | if !Flag_cocci.show_diff then begin |
| 264 | match Common.fst(Compare_c.compare_to_original cfile outfile) with |
| 265 | Compare_c.Correct -> () (* diff only in spacing, etc *) |
| 266 | | _ -> |
| 267 | (* may need --strip-trailing-cr under windows *) |
| 268 | pr2 "diff = "; |
| 269 | |
| 270 | let line = |
| 271 | match !Flag_parsing_c.diff_lines with |
| 272 | | None -> "diff -u -p " ^ cfile ^ " " ^ outfile |
| 273 | | Some n -> "diff -U "^n^" -p "^cfile^" "^outfile in |
| 274 | let res = Common.cmd_to_list line in |
| 275 | let res = |
| 276 | List.map |
| 277 | (function l -> |
| 278 | match Str.split (Str.regexp "[ \t]+") l with |
| 279 | "---"::file::date -> "--- "^file |
| 280 | | "+++"::file::date -> "+++ "^file |
| 281 | | _ -> l) |
| 282 | res in |
| 283 | let xs = |
| 284 | match (!Flag.patch,res) with |
| 285 | (* create something that looks like the output of patch *) |
| 286 | (Some prefix,minus_file::plus_file::rest) -> |
| 287 | let prefix = |
| 288 | let lp = String.length prefix in |
| 289 | if String.get prefix (lp-1) = '/' |
| 290 | then String.sub prefix 0 (lp-1) |
| 291 | else prefix in |
| 292 | let drop_prefix file = |
| 293 | let file = normalize_path file in |
| 294 | if Str.string_match (Str.regexp prefix) file 0 |
| 295 | then |
| 296 | let lp = String.length prefix in |
| 297 | let lf = String.length file in |
| 298 | if lp < lf |
| 299 | then String.sub file lp (lf - lp) |
| 300 | else |
| 301 | failwith |
| 302 | (Printf.sprintf "prefix %s doesn't match file %s" |
| 303 | prefix file) |
| 304 | else |
| 305 | failwith |
| 306 | (Printf.sprintf "prefix %s doesn't match file %s" |
| 307 | prefix file) in |
| 308 | let diff_line = |
| 309 | match List.rev(Str.split (Str.regexp " ") line) with |
| 310 | new_file::old_file::cmdrev -> |
| 311 | let old_base_file = drop_prefix old_file in |
| 312 | if !Flag.sgrep_mode2 |
| 313 | then |
| 314 | String.concat " " |
| 315 | (List.rev |
| 316 | (("/tmp/nothing"^old_base_file) |
| 317 | :: old_file :: cmdrev)) |
| 318 | else |
| 319 | String.concat " " |
| 320 | (List.rev |
| 321 | (("b"^old_base_file)::("a"^old_base_file):: |
| 322 | cmdrev)) |
| 323 | | _ -> failwith "bad command" in |
| 324 | let (minus_line,plus_line) = |
| 325 | match (Str.split (Str.regexp "[ \t]") minus_file, |
| 326 | Str.split (Str.regexp "[ \t]") plus_file) with |
| 327 | ("---"::old_file::old_rest,"+++"::new_file::new_rest) -> |
| 328 | let old_base_file = drop_prefix old_file in |
| 329 | if !Flag.sgrep_mode2 |
| 330 | then (minus_file,"+++ /tmp/nothing"^old_base_file) |
| 331 | else |
| 332 | (String.concat " " |
| 333 | ("---"::("a"^old_base_file)::old_rest), |
| 334 | String.concat " " |
| 335 | ("+++"::("b"^old_base_file)::new_rest)) |
| 336 | | (l1,l2) -> |
| 337 | failwith |
| 338 | (Printf.sprintf "bad diff header lines: %s %s" |
| 339 | (String.concat ":" l1) (String.concat ":" l2)) in |
| 340 | diff_line::minus_line::plus_line::rest |
| 341 | | _ -> res in |
| 342 | let xs = if !Flag.sgrep_mode2 then fix_sgrep_diffs xs else xs in |
| 343 | let cfile = normalize_path cfile in |
| 344 | let patches = |
| 345 | try Hashtbl.find generated_patches cfile |
| 346 | with Not_found -> |
| 347 | let cell = ref [] in |
| 348 | Hashtbl.add generated_patches cfile cell; |
| 349 | cell in |
| 350 | if List.mem xs !patches |
| 351 | then () |
| 352 | else |
| 353 | begin |
| 354 | patches := xs :: !patches; |
| 355 | xs +> List.iter pr |
| 356 | end |
| 357 | end |
| 358 | let show_or_not_diff a b = |
| 359 | Common.profile_code "show_xxx" (fun () -> show_or_not_diff2 a b) |
| 360 | |
| 361 | |
| 362 | (* the derived input *) |
| 363 | |
| 364 | let show_or_not_ctl_tex2 astcocci ctls = |
| 365 | if !Flag_cocci.show_ctl_tex then begin |
| 366 | let ctls = |
| 367 | List.map |
| 368 | (List.map |
| 369 | (function ((Asttoctl2.NONDECL ctl | Asttoctl2.CODE ctl),x) -> |
| 370 | (ctl,x))) |
| 371 | ctls in |
| 372 | Ctltotex.totex ("/tmp/__cocci_ctl.tex") astcocci ctls; |
| 373 | Common.command2 ("cd /tmp; latex __cocci_ctl.tex; " ^ |
| 374 | "dvips __cocci_ctl.dvi -o __cocci_ctl.ps;" ^ |
| 375 | "gv __cocci_ctl.ps &"); |
| 376 | end |
| 377 | let show_or_not_ctl_tex a b = |
| 378 | Common.profile_code "show_xxx" (fun () -> show_or_not_ctl_tex2 a b) |
| 379 | |
| 380 | |
| 381 | let show_or_not_rule_name ast rulenb = |
| 382 | if !Flag_cocci.show_ctl_text or !Flag.show_trying or |
| 383 | !Flag.show_transinfo or !Flag_cocci.show_binding_in_out |
| 384 | then |
| 385 | begin |
| 386 | let name = |
| 387 | match ast with |
| 388 | Ast_cocci.CocciRule (nm, (deps, drops, exists), x, _, _) -> nm |
| 389 | | _ -> i_to_s rulenb in |
| 390 | Common.pr_xxxxxxxxxxxxxxxxx (); |
| 391 | pr (name ^ " = "); |
| 392 | Common.pr_xxxxxxxxxxxxxxxxx () |
| 393 | end |
| 394 | |
| 395 | let show_or_not_scr_rule_name rulenb = |
| 396 | if !Flag_cocci.show_ctl_text or !Flag.show_trying or |
| 397 | !Flag.show_transinfo or !Flag_cocci.show_binding_in_out |
| 398 | then |
| 399 | begin |
| 400 | let name = i_to_s rulenb in |
| 401 | Common.pr_xxxxxxxxxxxxxxxxx (); |
| 402 | pr ("script rule " ^ name ^ " = "); |
| 403 | Common.pr_xxxxxxxxxxxxxxxxx () |
| 404 | end |
| 405 | |
| 406 | let show_or_not_ctl_text2 ctl ast rulenb = |
| 407 | if !Flag_cocci.show_ctl_text then begin |
| 408 | |
| 409 | adjust_pp_with_indent (fun () -> |
| 410 | Format.force_newline(); |
| 411 | Pretty_print_cocci.print_plus_flag := true; |
| 412 | Pretty_print_cocci.print_minus_flag := true; |
| 413 | Pretty_print_cocci.unparse ast; |
| 414 | ); |
| 415 | |
| 416 | pr "CTL = "; |
| 417 | let ((Asttoctl2.CODE ctl | Asttoctl2.NONDECL ctl),_) = ctl in |
| 418 | adjust_pp_with_indent (fun () -> |
| 419 | Format.force_newline(); |
| 420 | Pretty_print_engine.pp_ctlcocci |
| 421 | !Flag_cocci.show_mcodekind_in_ctl !Flag_cocci.inline_let_ctl ctl; |
| 422 | ); |
| 423 | pr ""; |
| 424 | end |
| 425 | let show_or_not_ctl_text a b c = |
| 426 | Common.profile_code "show_xxx" (fun () -> show_or_not_ctl_text2 a b c) |
| 427 | |
| 428 | |
| 429 | |
| 430 | (* running information *) |
| 431 | let get_celem celem : string = |
| 432 | match celem with |
| 433 | Ast_c.Definition ({Ast_c.f_name = namefuncs;},_) -> |
| 434 | Ast_c.str_of_name namefuncs |
| 435 | | Ast_c.Declaration |
| 436 | (Ast_c.DeclList ([{Ast_c.v_namei = Some (name, _);}, _], _)) -> |
| 437 | Ast_c.str_of_name name |
| 438 | | _ -> "" |
| 439 | |
| 440 | let show_or_not_celem2 prelude celem = |
| 441 | let (tag,trying) = |
| 442 | (match celem with |
| 443 | | Ast_c.Definition ({Ast_c.f_name = namefuncs},_) -> |
| 444 | let funcs = Ast_c.str_of_name namefuncs in |
| 445 | Flag.current_element := funcs; |
| 446 | (" function: ",funcs) |
| 447 | | Ast_c.Declaration |
| 448 | (Ast_c.DeclList ([{Ast_c.v_namei = Some (name,_)}, _], _)) -> |
| 449 | let s = Ast_c.str_of_name name in |
| 450 | Flag.current_element := s; |
| 451 | (" variable ",s); |
| 452 | | _ -> |
| 453 | Flag.current_element := "something_else"; |
| 454 | (" ","something else"); |
| 455 | ) in |
| 456 | if !Flag.show_trying then pr2 (prelude ^ tag ^ trying) |
| 457 | |
| 458 | let show_or_not_celem a b = |
| 459 | Common.profile_code "show_xxx" (fun () -> show_or_not_celem2 a b) |
| 460 | |
| 461 | |
| 462 | let show_or_not_trans_info2 trans_info = |
| 463 | (* drop witness tree indices for printing *) |
| 464 | let trans_info = |
| 465 | List.map (function (index,trans_info) -> trans_info) trans_info in |
| 466 | if !Flag.show_transinfo then begin |
| 467 | if null trans_info then pr2 "transformation info is empty" |
| 468 | else begin |
| 469 | pr2 "transformation info returned:"; |
| 470 | let trans_info = |
| 471 | List.sort (function (i1,_,_) -> function (i2,_,_) -> compare i1 i2) |
| 472 | trans_info |
| 473 | in |
| 474 | indent_do (fun () -> |
| 475 | trans_info +> List.iter (fun (i, subst, re) -> |
| 476 | pr2 ("transform state: " ^ (Common.i_to_s i)); |
| 477 | indent_do (fun () -> |
| 478 | adjust_pp_with_indent_and_header "with rule_elem: " (fun () -> |
| 479 | Pretty_print_cocci.print_plus_flag := true; |
| 480 | Pretty_print_cocci.print_minus_flag := true; |
| 481 | Pretty_print_cocci.rule_elem "" re; |
| 482 | ); |
| 483 | adjust_pp_with_indent_and_header "with binding: " (fun () -> |
| 484 | Pretty_print_engine.pp_binding subst; |
| 485 | ); |
| 486 | ) |
| 487 | ); |
| 488 | ) |
| 489 | end |
| 490 | end |
| 491 | let show_or_not_trans_info a = |
| 492 | Common.profile_code "show_xxx" (fun () -> show_or_not_trans_info2 a) |
| 493 | |
| 494 | |
| 495 | |
| 496 | let show_or_not_binding2 s binding = |
| 497 | if !Flag_cocci.show_binding_in_out then begin |
| 498 | adjust_pp_with_indent_and_header ("binding " ^ s ^ " = ") (fun () -> |
| 499 | Pretty_print_engine.pp_binding binding |
| 500 | ) |
| 501 | end |
| 502 | let show_or_not_binding a b = |
| 503 | Common.profile_code "show_xxx" (fun () -> show_or_not_binding2 a b) |
| 504 | |
| 505 | |
| 506 | |
| 507 | (*****************************************************************************) |
| 508 | (* Some helper functions *) |
| 509 | (*****************************************************************************) |
| 510 | |
| 511 | let worth_trying cfiles tokens = |
| 512 | (* drop the following line for a list of list by rules. since we don't |
| 513 | allow multiple minirules, all the tokens within a rule should be in |
| 514 | a single CFG entity *) |
| 515 | match (!Flag_cocci.windows,tokens) with |
| 516 | (true,_) | (_,None) -> true |
| 517 | | (_,Some tokens) -> |
| 518 | (* could also modify the code in get_constants.ml *) |
| 519 | let tokens = tokens +> List.map (fun s -> |
| 520 | match () with |
| 521 | | _ when s =~ "^[A-Za-z_][A-Za-z_0-9]*$" -> |
| 522 | "\\b" ^ s ^ "\\b" |
| 523 | |
| 524 | | _ when s =~ "^[A-Za-z_]" -> |
| 525 | "\\b" ^ s |
| 526 | |
| 527 | | _ when s =~ ".*[A-Za-z_]$" -> |
| 528 | s ^ "\\b" |
| 529 | | _ -> s |
| 530 | |
| 531 | ) in |
| 532 | let com = sprintf "egrep -q '(%s)' %s" (join "|" tokens) (join " " cfiles) |
| 533 | in |
| 534 | (match Sys.command com with |
| 535 | | 0 (* success *) -> true |
| 536 | | _ (* failure *) -> |
| 537 | (if !Flag.show_misc |
| 538 | then Printf.printf "grep failed: %s\n" com); |
| 539 | false (* no match, so not worth trying *)) |
| 540 | |
| 541 | let check_macro_in_sp_and_adjust = function |
| 542 | None -> () |
| 543 | | Some tokens -> |
| 544 | tokens +> List.iter (fun s -> |
| 545 | if Hashtbl.mem !Parse_c._defs s |
| 546 | then begin |
| 547 | if !Flag_cocci.verbose_cocci then begin |
| 548 | pr2 "warning: macro in semantic patch was in macro definitions"; |
| 549 | pr2 ("disabling macro expansion for " ^ s); |
| 550 | end; |
| 551 | Hashtbl.remove !Parse_c._defs s |
| 552 | end) |
| 553 | |
| 554 | |
| 555 | let contain_loop gopt = |
| 556 | match gopt with |
| 557 | | Some g -> |
| 558 | g#nodes#tolist +> List.exists (fun (xi, node) -> |
| 559 | Control_flow_c.extract_is_loop node |
| 560 | ) |
| 561 | | None -> true (* means nothing, if no g then will not model check *) |
| 562 | |
| 563 | |
| 564 | |
| 565 | let sp_contain_typed_metavar_z toplevel_list_list = |
| 566 | let bind x y = x or y in |
| 567 | let option_default = false in |
| 568 | let mcode _ _ = option_default in |
| 569 | let donothing r k e = k e in |
| 570 | |
| 571 | let expression r k e = |
| 572 | match Ast_cocci.unwrap e with |
| 573 | | Ast_cocci.MetaExpr (_,_,_,Some t,_,_) -> true |
| 574 | | Ast_cocci.MetaExpr (_,_,_,_,Ast_cocci.LocalID,_) -> true |
| 575 | | _ -> k e |
| 576 | in |
| 577 | |
| 578 | let combiner = |
| 579 | Visitor_ast.combiner bind option_default |
| 580 | mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode |
| 581 | donothing donothing donothing donothing donothing |
| 582 | donothing expression donothing donothing donothing donothing donothing |
| 583 | donothing donothing donothing donothing donothing |
| 584 | in |
| 585 | toplevel_list_list +> |
| 586 | List.exists |
| 587 | (function (nm,_,rule) -> |
| 588 | (List.exists combiner.Visitor_ast.combiner_top_level rule)) |
| 589 | |
| 590 | let sp_contain_typed_metavar rules = |
| 591 | sp_contain_typed_metavar_z |
| 592 | (List.map |
| 593 | (function x -> |
| 594 | match x with |
| 595 | Ast_cocci.CocciRule (a,b,c,d,_) -> (a,b,c) |
| 596 | | _ -> failwith "error in filter") |
| 597 | (List.filter |
| 598 | (function x -> |
| 599 | match x with |
| 600 | Ast_cocci.CocciRule (a,b,c,d,Ast_cocci.Normal) -> true |
| 601 | | _ -> false) |
| 602 | rules)) |
| 603 | |
| 604 | |
| 605 | |
| 606 | (* finding among the #include the one that we need to parse |
| 607 | * because they may contain useful type definition or because |
| 608 | * we may have to modify them |
| 609 | * |
| 610 | * For the moment we base in part our heuristic on the name of the file, e.g. |
| 611 | * serio.c is related we think to #include <linux/serio.h> |
| 612 | *) |
| 613 | let include_table = Hashtbl.create(100) |
| 614 | |
| 615 | let interpret_include_path relpath = |
| 616 | let maxdepth = List.length relpath in |
| 617 | let unique_file_exists dir f = |
| 618 | let cmd = |
| 619 | Printf.sprintf "find %s -maxdepth %d -mindepth %d -path \"*/%s\"" |
| 620 | dir maxdepth maxdepth f in |
| 621 | match Common.cmd_to_list cmd with |
| 622 | [x] -> Some x |
| 623 | | _ -> None in |
| 624 | let native_file_exists dir f = |
| 625 | let f = Filename.concat dir f in |
| 626 | if Sys.file_exists f |
| 627 | then Some f |
| 628 | else None in |
| 629 | let rec search_include_path exists searchlist relpath = |
| 630 | match searchlist with |
| 631 | [] -> None |
| 632 | | hd::tail -> |
| 633 | (match exists hd relpath with |
| 634 | Some x -> Some x |
| 635 | | None -> search_include_path exists tail relpath) in |
| 636 | let rec search_path exists searchlist = function |
| 637 | [] -> |
| 638 | let res = Common.concat "/" relpath in |
| 639 | Hashtbl.add include_table (searchlist,relpath) res; |
| 640 | Some res |
| 641 | | (hd::tail) as relpath1 -> |
| 642 | let relpath1 = Common.concat "/" relpath1 in |
| 643 | (match search_include_path exists searchlist relpath1 with |
| 644 | None -> search_path unique_file_exists searchlist tail |
| 645 | | Some f -> |
| 646 | Hashtbl.add include_table (searchlist,relpath) f; |
| 647 | Some f) in |
| 648 | let searchlist = |
| 649 | match !Flag_cocci.include_path with |
| 650 | [] -> ["include"] |
| 651 | | x -> List.rev x in |
| 652 | try Some(Hashtbl.find include_table (searchlist,relpath)) |
| 653 | with Not_found -> |
| 654 | search_path native_file_exists searchlist relpath |
| 655 | |
| 656 | let (includes_to_parse: |
| 657 | (Common.filename * Parse_c.extended_program2) list -> |
| 658 | Flag_cocci.include_options -> 'a) = fun xs choose_includes -> |
| 659 | match choose_includes with |
| 660 | Flag_cocci.I_UNSPECIFIED -> failwith "not possible" |
| 661 | | Flag_cocci.I_NO_INCLUDES -> !Flag_cocci.extra_includes |
| 662 | | x -> |
| 663 | let all_includes = |
| 664 | List.mem x |
| 665 | [Flag_cocci.I_ALL_INCLUDES; Flag_cocci.I_REALLY_ALL_INCLUDES] in |
| 666 | let xs = List.map (function (file,(cs,_,_)) -> (file,cs)) xs in |
| 667 | xs +> List.map (fun (file, cs) -> |
| 668 | let dir = Common.dirname file in |
| 669 | |
| 670 | cs +> Common.map_filter (fun (c,_info_item) -> |
| 671 | match c with |
| 672 | | Ast_c.CppTop |
| 673 | (Ast_c.Include |
| 674 | {Ast_c.i_include = ((x,ii)); i_rel_pos = info_h_pos;}) -> |
| 675 | (match x with |
| 676 | | Ast_c.Local xs -> |
| 677 | let relpath = Common.join "/" xs in |
| 678 | let f = Filename.concat dir relpath in |
| 679 | if (Sys.file_exists f) then |
| 680 | Some f |
| 681 | else |
| 682 | if !Flag_cocci.relax_include_path |
| 683 | (* for our tests, all the files are flat in the current dir *) |
| 684 | then |
| 685 | let attempt2 = Filename.concat dir (Common.last xs) in |
| 686 | if not (Sys.file_exists attempt2) && all_includes |
| 687 | then |
| 688 | interpret_include_path xs |
| 689 | else Some attempt2 |
| 690 | else |
| 691 | if all_includes then interpret_include_path xs |
| 692 | else None |
| 693 | |
| 694 | | Ast_c.NonLocal xs -> |
| 695 | if all_includes || |
| 696 | Common.fileprefix (Common.last xs) =$= Common.fileprefix file |
| 697 | then |
| 698 | interpret_include_path xs |
| 699 | else None |
| 700 | | Ast_c.Weird _ -> None |
| 701 | ) |
| 702 | | _ -> None)) |
| 703 | +> List.concat |
| 704 | +> (fun x -> |
| 705 | (List.rev |
| 706 | (Common.uniq |
| 707 | (!Flag_cocci.extra_includes@(List.rev x)))))(*uniq keeps last*) |
| 708 | |
| 709 | let rec interpret_dependencies local global = function |
| 710 | Ast_cocci.Dep s -> List.mem s local |
| 711 | | Ast_cocci.AntiDep s -> |
| 712 | (if !Flag_ctl.steps != None |
| 713 | then failwith "steps and ! dependency incompatible"); |
| 714 | not (List.mem s local) |
| 715 | | Ast_cocci.EverDep s -> List.mem s global |
| 716 | | Ast_cocci.NeverDep s -> |
| 717 | (if !Flag_ctl.steps != None |
| 718 | then failwith "steps and ! dependency incompatible"); |
| 719 | not (List.mem s global) |
| 720 | | Ast_cocci.AndDep(s1,s2) -> |
| 721 | (interpret_dependencies local global s1) && |
| 722 | (interpret_dependencies local global s2) |
| 723 | | Ast_cocci.OrDep(s1,s2) -> |
| 724 | (interpret_dependencies local global s1) or |
| 725 | (interpret_dependencies local global s2) |
| 726 | | Ast_cocci.NoDep -> true |
| 727 | | Ast_cocci.FailDep -> false |
| 728 | |
| 729 | let rec print_dependencies str local global dep = |
| 730 | if !Flag_cocci.show_dependencies |
| 731 | then |
| 732 | begin |
| 733 | pr2 str; |
| 734 | let seen = ref [] in |
| 735 | let rec loop = function |
| 736 | Ast_cocci.Dep s | Ast_cocci.AntiDep s -> |
| 737 | if not (List.mem s !seen) |
| 738 | then |
| 739 | begin |
| 740 | if List.mem s local |
| 741 | then pr2 (s^" satisfied") |
| 742 | else pr2 (s^" not satisfied"); |
| 743 | seen := s :: !seen |
| 744 | end |
| 745 | | Ast_cocci.EverDep s | Ast_cocci.NeverDep s -> |
| 746 | if not (List.mem s !seen) |
| 747 | then |
| 748 | begin |
| 749 | if List.mem s global |
| 750 | then pr2 (s^" satisfied") |
| 751 | else pr2 (s^" not satisfied"); |
| 752 | seen := s :: !seen |
| 753 | end |
| 754 | | Ast_cocci.AndDep(s1,s2) -> |
| 755 | loop s1; |
| 756 | loop s2 |
| 757 | | Ast_cocci.OrDep(s1,s2) -> |
| 758 | loop s1; |
| 759 | loop s2 |
| 760 | | Ast_cocci.NoDep -> () |
| 761 | | Ast_cocci.FailDep -> pr2 "False not satisfied" in |
| 762 | loop dep |
| 763 | end |
| 764 | |
| 765 | (* --------------------------------------------------------------------- *) |
| 766 | (* #include relative position in the file *) |
| 767 | (* --------------------------------------------------------------------- *) |
| 768 | |
| 769 | (* compute the set of new prefixes |
| 770 | * on |
| 771 | * "a/b/x"; (* in fact it is now a list of string so ["a";"b";"x"] *) |
| 772 | * "a/b/c/x"; |
| 773 | * "a/x"; |
| 774 | * "b/x"; |
| 775 | * it would give for the first element |
| 776 | * ""; "a"; "a/b"; "a/b/x" |
| 777 | * for the second |
| 778 | * "a/b/c/x" |
| 779 | * |
| 780 | * update: if the include is inside a ifdef a put nothing. cf -test incl. |
| 781 | * this is because we dont want code added inside ifdef. |
| 782 | *) |
| 783 | |
| 784 | let compute_new_prefixes xs = |
| 785 | xs +> Common.map_withenv (fun already xs -> |
| 786 | let subdirs_prefixes = Common.inits xs in |
| 787 | let new_first = subdirs_prefixes +> List.filter (fun x -> |
| 788 | not (List.mem x already) |
| 789 | ) |
| 790 | in |
| 791 | new_first, |
| 792 | new_first @ already |
| 793 | ) [] |
| 794 | +> fst |
| 795 | |
| 796 | |
| 797 | (* does via side effect on the ref in the Include in Ast_c *) |
| 798 | let rec update_include_rel_pos cs = |
| 799 | let only_include = cs +> Common.map_filter (fun c -> |
| 800 | match c with |
| 801 | | Ast_c.CppTop (Ast_c.Include {Ast_c.i_include = ((x,_)); |
| 802 | i_rel_pos = aref; |
| 803 | i_is_in_ifdef = inifdef}) -> |
| 804 | (match x with |
| 805 | | Ast_c.Weird _ -> None |
| 806 | | _ -> |
| 807 | if inifdef |
| 808 | then None |
| 809 | else Some (x, aref) |
| 810 | ) |
| 811 | | _ -> None |
| 812 | ) |
| 813 | in |
| 814 | let (locals, nonlocals) = |
| 815 | only_include +> Common.partition_either (fun (c, aref) -> |
| 816 | match c with |
| 817 | | Ast_c.Local x -> Left (x, aref) |
| 818 | | Ast_c.NonLocal x -> Right (x, aref) |
| 819 | | Ast_c.Weird x -> raise (Impossible 161) |
| 820 | ) in |
| 821 | |
| 822 | update_rel_pos_bis locals; |
| 823 | update_rel_pos_bis nonlocals; |
| 824 | cs |
| 825 | and update_rel_pos_bis xs = |
| 826 | let xs' = List.map fst xs in |
| 827 | let the_first = compute_new_prefixes xs' in |
| 828 | let the_last = List.rev (compute_new_prefixes (List.rev xs')) in |
| 829 | let merged = Common.zip xs (Common.zip the_first the_last) in |
| 830 | merged +> List.iter (fun ((x, aref), (the_first, the_last)) -> |
| 831 | aref := Some |
| 832 | { |
| 833 | Ast_c.first_of = the_first; |
| 834 | Ast_c.last_of = the_last; |
| 835 | } |
| 836 | ) |
| 837 | |
| 838 | |
| 839 | (*****************************************************************************) |
| 840 | (* All the information needed around the C elements and Cocci rules *) |
| 841 | (*****************************************************************************) |
| 842 | |
| 843 | type toplevel_c_info = { |
| 844 | ast_c: Ast_c.toplevel; (* contain refs so can be modified *) |
| 845 | tokens_c: Parser_c.token list; |
| 846 | fullstring: string; |
| 847 | |
| 848 | flow: Control_flow_c.cflow option; (* it's the "fixed" flow *) |
| 849 | contain_loop: bool; |
| 850 | |
| 851 | env_typing_before: TAC.environment; |
| 852 | env_typing_after: TAC.environment; |
| 853 | |
| 854 | was_modified: bool ref; |
| 855 | |
| 856 | all_typedefs: (string, Lexer_parser.identkind) Common.scoped_h_env; |
| 857 | all_macros: (string, Cpp_token_c.define_def) Hashtbl.t; |
| 858 | |
| 859 | (* id: int *) |
| 860 | } |
| 861 | |
| 862 | type rule_info = { |
| 863 | rulename: string; |
| 864 | dependencies: Ast_cocci.dependency; |
| 865 | used_after: Ast_cocci.meta_name list; |
| 866 | ruleid: int; |
| 867 | was_matched: bool ref; |
| 868 | } |
| 869 | |
| 870 | type toplevel_cocci_info_script_rule = { |
| 871 | scr_ast_rule: |
| 872 | string * |
| 873 | (Ast_cocci.script_meta_name * Ast_cocci.meta_name * |
| 874 | Ast_cocci.metavar) list * |
| 875 | Ast_cocci.meta_name list (*fresh vars*) * |
| 876 | string; |
| 877 | language: string; |
| 878 | script_code: string; |
| 879 | scr_rule_info: rule_info; |
| 880 | } |
| 881 | |
| 882 | type toplevel_cocci_info_cocci_rule = { |
| 883 | ctl: Asttoctl2.top_formula * (CCI.pred list list); |
| 884 | metavars: Ast_cocci.metavar list; |
| 885 | ast_rule: Ast_cocci.rule; |
| 886 | isexp: bool; (* true if + code is an exp, only for Flag.make_hrule *) |
| 887 | |
| 888 | (* There are also some hardcoded rule names in parse_cocci.ml: |
| 889 | * let reserved_names = ["all";"optional_storage";"optional_qualifier"] |
| 890 | *) |
| 891 | dropped_isos: string list; |
| 892 | free_vars: Ast_cocci.meta_name list; |
| 893 | negated_pos_vars: Ast_cocci.meta_name list; |
| 894 | positions: Ast_cocci.meta_name list; |
| 895 | |
| 896 | ruletype: Ast_cocci.ruletype; |
| 897 | |
| 898 | rule_info: rule_info; |
| 899 | } |
| 900 | |
| 901 | type toplevel_cocci_info = |
| 902 | ScriptRuleCocciInfo of toplevel_cocci_info_script_rule |
| 903 | | InitialScriptRuleCocciInfo of toplevel_cocci_info_script_rule |
| 904 | | FinalScriptRuleCocciInfo of toplevel_cocci_info_script_rule |
| 905 | | CocciRuleCocciInfo of toplevel_cocci_info_cocci_rule |
| 906 | |
| 907 | type cocci_info = toplevel_cocci_info list * string list option (* tokens *) |
| 908 | |
| 909 | type kind_file = Header | Source |
| 910 | type file_info = { |
| 911 | fname : string; |
| 912 | full_fname : string; |
| 913 | was_modified_once: bool ref; |
| 914 | asts: toplevel_c_info list; |
| 915 | fpath : string; |
| 916 | fkind : kind_file; |
| 917 | } |
| 918 | |
| 919 | let g_contain_typedmetavar = ref false |
| 920 | |
| 921 | |
| 922 | let last_env_toplevel_c_info xs = |
| 923 | (Common.last xs).env_typing_after |
| 924 | |
| 925 | let concat_headers_and_c (ccs: file_info list) |
| 926 | : (toplevel_c_info * string) list = |
| 927 | (List.concat (ccs +> List.map (fun x -> |
| 928 | x.asts +> List.map (fun x' -> |
| 929 | (x', x.fname))))) |
| 930 | |
| 931 | let for_unparser xs = |
| 932 | xs +> List.map (fun x -> |
| 933 | (x.ast_c, (x.fullstring, x.tokens_c)), Unparse_c.PPviastr |
| 934 | ) |
| 935 | |
| 936 | let gen_pdf_graph () = |
| 937 | (Ctl_engine.get_graph_files ()) +> List.iter (fun outfile -> |
| 938 | Printf.printf "Generation of %s%!" outfile; |
| 939 | let filename_stack = Ctl_engine.get_graph_comp_files outfile in |
| 940 | List.iter (fun filename -> |
| 941 | ignore (Unix.system ("dot " ^ filename ^ " -Tpdf -o " ^ filename ^ ".pdf;")) |
| 942 | ) filename_stack; |
| 943 | let (head,tail) = (List.hd filename_stack, List.tl filename_stack) in |
| 944 | ignore(Unix.system ("cp " ^ head ^ ".pdf " ^ outfile ^ ".pdf;")); |
| 945 | tail +> List.iter (fun filename -> |
| 946 | ignore(Unix.system ("mv " ^ outfile ^ ".pdf /tmp/tmp.pdf;")); |
| 947 | ignore(Unix.system ("pdftk " ^ filename ^ ".pdf /tmp/tmp.pdf cat output " ^ outfile ^ ".pdf")); |
| 948 | ); |
| 949 | ignore(Unix.system ("rm /tmp/tmp.pdf;")); |
| 950 | List.iter (fun filename -> |
| 951 | ignore (Unix.system ("rm " ^ filename ^ " " ^ filename ^ ".pdf;")) |
| 952 | ) filename_stack; |
| 953 | Printf.printf " - Done\n") |
| 954 | |
| 955 | let local_python_code = |
| 956 | "from coccinelle import *\n" |
| 957 | |
| 958 | let python_code = |
| 959 | "import coccinelle\n"^ |
| 960 | "import coccilib\n"^ |
| 961 | "import coccilib.org\n"^ |
| 962 | "import coccilib.report\n" ^ |
| 963 | local_python_code ^ |
| 964 | "cocci = Cocci()\n" |
| 965 | |
| 966 | let make_init lang code rule_info = |
| 967 | let mv = [] in |
| 968 | { |
| 969 | scr_ast_rule = (lang, mv, [], code); |
| 970 | language = lang; |
| 971 | script_code = (if lang = "python" then python_code else "") ^code; |
| 972 | scr_rule_info = rule_info; |
| 973 | } |
| 974 | |
| 975 | (* --------------------------------------------------------------------- *) |
| 976 | let prepare_cocci ctls free_var_lists negated_pos_lists |
| 977 | (ua,fua,fuas) positions_list metavars astcocci = |
| 978 | |
| 979 | let gathered = Common.index_list_1 |
| 980 | (zip (zip (zip (zip (zip (zip (zip (zip ctls metavars) astcocci) |
| 981 | free_var_lists) |
| 982 | negated_pos_lists) ua) fua) fuas) positions_list) |
| 983 | in |
| 984 | gathered +> List.map |
| 985 | (fun (((((((((ctl_toplevel_list,metavars),ast),free_var_list), |
| 986 | negated_pos_list),ua),fua),fuas),positions_list),rulenb) -> |
| 987 | |
| 988 | let build_rule_info rulename deps = |
| 989 | {rulename = rulename; |
| 990 | dependencies = deps; |
| 991 | used_after = (List.hd ua) @ (List.hd fua); |
| 992 | ruleid = rulenb; |
| 993 | was_matched = ref false;} in |
| 994 | |
| 995 | let is_script_rule r = |
| 996 | match r with |
| 997 | Ast_cocci.ScriptRule _ |
| 998 | | Ast_cocci.InitialScriptRule _ | Ast_cocci.FinalScriptRule _ -> true |
| 999 | | _ -> false in |
| 1000 | |
| 1001 | if not (List.length ctl_toplevel_list =|= 1) && not (is_script_rule ast) |
| 1002 | then failwith "not handling multiple minirules"; |
| 1003 | |
| 1004 | match ast with |
| 1005 | Ast_cocci.ScriptRule (name,lang,deps,mv,script_vars,code) -> |
| 1006 | let r = |
| 1007 | { |
| 1008 | scr_ast_rule = (lang, mv, script_vars, code); |
| 1009 | language = lang; |
| 1010 | script_code = code; |
| 1011 | scr_rule_info = build_rule_info name deps; |
| 1012 | } |
| 1013 | in ScriptRuleCocciInfo r |
| 1014 | | Ast_cocci.InitialScriptRule (name,lang,deps,code) -> |
| 1015 | let r = make_init lang code (build_rule_info name deps) in |
| 1016 | InitialScriptRuleCocciInfo r |
| 1017 | | Ast_cocci.FinalScriptRule (name,lang,deps,code) -> |
| 1018 | let mv = [] in |
| 1019 | let r = |
| 1020 | { |
| 1021 | scr_ast_rule = (lang, mv, [], code); |
| 1022 | language = lang; |
| 1023 | script_code = code; |
| 1024 | scr_rule_info = build_rule_info name deps; |
| 1025 | } |
| 1026 | in FinalScriptRuleCocciInfo r |
| 1027 | | Ast_cocci.CocciRule |
| 1028 | (rulename,(dependencies,dropped_isos,z),restast,isexp,ruletype) -> |
| 1029 | CocciRuleCocciInfo ( |
| 1030 | { |
| 1031 | ctl = List.hd ctl_toplevel_list; |
| 1032 | metavars = metavars; |
| 1033 | ast_rule = ast; |
| 1034 | isexp = List.hd isexp; |
| 1035 | dropped_isos = dropped_isos; |
| 1036 | free_vars = List.hd free_var_list; |
| 1037 | negated_pos_vars = List.hd negated_pos_list; |
| 1038 | positions = List.hd positions_list; |
| 1039 | ruletype = ruletype; |
| 1040 | rule_info = build_rule_info rulename dependencies; |
| 1041 | }) |
| 1042 | ) |
| 1043 | |
| 1044 | (* --------------------------------------------------------------------- *) |
| 1045 | |
| 1046 | let build_info_program (cprogram,typedefs,macros) env = |
| 1047 | |
| 1048 | let (cs, parseinfos) = |
| 1049 | Common.unzip cprogram in |
| 1050 | |
| 1051 | let alltoks = |
| 1052 | parseinfos +> List.map (fun (s,toks) -> toks) +> List.flatten in |
| 1053 | |
| 1054 | (* I use cs' but really annotate_xxx work by doing side effects on cs *) |
| 1055 | let cs' = |
| 1056 | Comment_annotater_c.annotate_program alltoks cs in |
| 1057 | |
| 1058 | let cs_with_envs = |
| 1059 | Type_annoter_c.annotate_program env (*!g_contain_typedmetavar*) cs' |
| 1060 | in |
| 1061 | |
| 1062 | zip cs_with_envs parseinfos +> List.map (fun ((c, (enva,envb)), parseinfo)-> |
| 1063 | let (fullstr, tokens) = parseinfo in |
| 1064 | |
| 1065 | let flow = |
| 1066 | ast_to_flow_with_error_messages c +> |
| 1067 | Common.map_option (fun flow -> |
| 1068 | let flow = Ast_to_flow.annotate_loop_nodes flow in |
| 1069 | |
| 1070 | (* remove the fake nodes for julia *) |
| 1071 | let fixed_flow = CCI.fix_flow_ctl flow in |
| 1072 | |
| 1073 | if !Flag_cocci.show_flow then print_flow fixed_flow; |
| 1074 | if !Flag_cocci.show_before_fixed_flow then print_flow flow; |
| 1075 | |
| 1076 | fixed_flow |
| 1077 | ) |
| 1078 | in |
| 1079 | { |
| 1080 | ast_c = c; (* contain refs so can be modified *) |
| 1081 | tokens_c = tokens; |
| 1082 | fullstring = fullstr; |
| 1083 | |
| 1084 | flow = flow; |
| 1085 | |
| 1086 | contain_loop = contain_loop flow; |
| 1087 | |
| 1088 | env_typing_before = enva; |
| 1089 | env_typing_after = envb; |
| 1090 | |
| 1091 | was_modified = ref false; |
| 1092 | |
| 1093 | all_typedefs = typedefs; |
| 1094 | all_macros = macros; |
| 1095 | }) |
| 1096 | |
| 1097 | |
| 1098 | |
| 1099 | (* Optimisation. Try not unparse/reparse the whole file when have modifs *) |
| 1100 | let rebuild_info_program cs file isexp = |
| 1101 | cs +> List.map (fun c -> |
| 1102 | if !(c.was_modified) |
| 1103 | then |
| 1104 | let file = Common.new_temp_file "cocci_small_output" ".c" in |
| 1105 | cfile_of_program |
| 1106 | [(c.ast_c, (c.fullstring, c.tokens_c)), Unparse_c.PPnormal] |
| 1107 | file; |
| 1108 | |
| 1109 | (* Common.command2 ("cat " ^ file); *) |
| 1110 | let cprogram = cprogram_of_file c.all_typedefs c.all_macros file in |
| 1111 | let xs = build_info_program cprogram c.env_typing_before in |
| 1112 | |
| 1113 | (* TODO: assert env has not changed, |
| 1114 | * if yes then must also reparse what follows even if not modified. |
| 1115 | * Do that only if contain_typedmetavar of course, so good opti. |
| 1116 | *) |
| 1117 | (* Common.list_init xs *) (* get rid of the FinalDef *) |
| 1118 | xs |
| 1119 | else [c] |
| 1120 | ) +> List.concat |
| 1121 | |
| 1122 | |
| 1123 | let rebuild_info_c_and_headers ccs isexp = |
| 1124 | ccs +> List.iter (fun c_or_h -> |
| 1125 | if c_or_h.asts +> List.exists (fun c -> !(c.was_modified)) |
| 1126 | then c_or_h.was_modified_once := true; |
| 1127 | ); |
| 1128 | ccs +> List.map (fun c_or_h -> |
| 1129 | { c_or_h with |
| 1130 | asts = |
| 1131 | rebuild_info_program c_or_h.asts c_or_h.full_fname isexp } |
| 1132 | ) |
| 1133 | |
| 1134 | let rec prepare_h seen env hpath choose_includes : file_info list = |
| 1135 | if not (Common.lfile_exists hpath) |
| 1136 | then |
| 1137 | begin |
| 1138 | pr2_once ("TYPE: header " ^ hpath ^ " not found"); |
| 1139 | [] |
| 1140 | end |
| 1141 | else |
| 1142 | begin |
| 1143 | let h_cs = cprogram_of_file_cached hpath in |
| 1144 | let local_includes = |
| 1145 | if choose_includes =*= Flag_cocci.I_REALLY_ALL_INCLUDES |
| 1146 | then |
| 1147 | List.filter |
| 1148 | (function x -> not (List.mem x !seen)) |
| 1149 | (includes_to_parse [(hpath,h_cs)] choose_includes) |
| 1150 | else [] in |
| 1151 | seen := local_includes @ !seen; |
| 1152 | let others = |
| 1153 | List.concat |
| 1154 | (List.map (function x -> prepare_h seen env x choose_includes) |
| 1155 | local_includes) in |
| 1156 | let info_h_cs = build_info_program h_cs !env in |
| 1157 | env := |
| 1158 | if null info_h_cs |
| 1159 | then !env |
| 1160 | else last_env_toplevel_c_info info_h_cs; |
| 1161 | others@ |
| 1162 | [{ |
| 1163 | fname = Common.basename hpath; |
| 1164 | full_fname = hpath; |
| 1165 | asts = info_h_cs; |
| 1166 | was_modified_once = ref false; |
| 1167 | fpath = hpath; |
| 1168 | fkind = Header; |
| 1169 | }] |
| 1170 | end |
| 1171 | |
| 1172 | let prepare_c files choose_includes : file_info list = |
| 1173 | let cprograms = List.map cprogram_of_file_cached files in |
| 1174 | let includes = includes_to_parse (zip files cprograms) choose_includes in |
| 1175 | let seen = ref includes in |
| 1176 | |
| 1177 | (* todo?: may not be good to first have all the headers and then all the c *) |
| 1178 | let env = ref !TAC.initial_env in |
| 1179 | |
| 1180 | let includes = |
| 1181 | includes +> |
| 1182 | List.map (function hpath -> prepare_h seen env hpath choose_includes) +> |
| 1183 | List.concat in |
| 1184 | |
| 1185 | let cfiles = |
| 1186 | (zip files cprograms) +> |
| 1187 | List.map |
| 1188 | (function (file, cprogram) -> |
| 1189 | (* todo?: don't update env ? *) |
| 1190 | let cs = build_info_program cprogram !env in |
| 1191 | (* we do that only for the c, not for the h *) |
| 1192 | ignore(update_include_rel_pos (cs +> List.map (fun x -> x.ast_c))); |
| 1193 | { |
| 1194 | fname = Common.basename file; |
| 1195 | full_fname = file; |
| 1196 | asts = cs; |
| 1197 | was_modified_once = ref false; |
| 1198 | fpath = file; |
| 1199 | fkind = Source |
| 1200 | }) in |
| 1201 | |
| 1202 | includes @ cfiles |
| 1203 | |
| 1204 | (*****************************************************************************) |
| 1205 | (* Manage environments as they are being built up *) |
| 1206 | (*****************************************************************************) |
| 1207 | |
| 1208 | let init_env _ = Hashtbl.create 101 |
| 1209 | |
| 1210 | let update_env env v i = Hashtbl.replace env v i; env |
| 1211 | |
| 1212 | (* know that there are no conflicts *) |
| 1213 | let safe_update_env env v i = Hashtbl.add env v i; env |
| 1214 | |
| 1215 | let end_env env = |
| 1216 | List.sort compare (Hashtbl.fold (fun k v rest -> (k,v) :: rest) env []) |
| 1217 | |
| 1218 | (*****************************************************************************) |
| 1219 | (* Processing the ctls and toplevel C elements *) |
| 1220 | (*****************************************************************************) |
| 1221 | |
| 1222 | (* The main algorithm =~ |
| 1223 | * The algorithm is roughly: |
| 1224 | * for_all ctl rules in SP |
| 1225 | * for_all minirule in rule (no more) |
| 1226 | * for_all binding (computed during previous phase) |
| 1227 | * for_all C elements |
| 1228 | * match control flow of function vs minirule |
| 1229 | * with the binding and update the set of possible |
| 1230 | * bindings, and returned the possibly modified function. |
| 1231 | * pretty print modified C elements and reparse it. |
| 1232 | * |
| 1233 | * |
| 1234 | * On ne prends que les newbinding ou returned_any_state est vrai. |
| 1235 | * Si ca ne donne rien, on prends ce qu'il y avait au depart. |
| 1236 | * Mais au nouveau depart de quoi ? |
| 1237 | * - si ca donne rien apres avoir traité toutes les fonctions avec ce binding ? |
| 1238 | * - ou alors si ca donne rien, apres avoir traité toutes les fonctions |
| 1239 | * avec tous les bindings du round d'avant ? |
| 1240 | * |
| 1241 | * Julia pense qu'il faut prendre la premiere solution. |
| 1242 | * Example: on a deux environnements candidats, E1 et E2 apres avoir traité |
| 1243 | * la regle ctl 1. On arrive sur la regle ctl 2. |
| 1244 | * E1 ne donne rien pour la regle 2, on garde quand meme E1 pour la regle 3. |
| 1245 | * E2 donne un match a un endroit et rend E2' alors on utilise ca pour |
| 1246 | * la regle 3. |
| 1247 | * |
| 1248 | * I have not to look at used_after_list to decide to restart from |
| 1249 | * scratch. I just need to look if the binding list is empty. |
| 1250 | * Indeed, let's suppose that a SP have 3 regions/rules. If we |
| 1251 | * don't find a match for the first region, then if this first |
| 1252 | * region does not bind metavariable used after, that is if |
| 1253 | * used_after_list is empty, then mysat(), even if does not find a |
| 1254 | * match, will return a Left, with an empty transformation_info, |
| 1255 | * and so current_binding will grow. On the contrary if the first |
| 1256 | * region must bind some metavariables used after, and that we |
| 1257 | * dont find any such region, then mysat() will returns lots of |
| 1258 | * Right, and current_binding will not grow, and so we will have |
| 1259 | * an empty list of binding, and we will catch such a case. |
| 1260 | * |
| 1261 | * opti: julia says that because the binding is |
| 1262 | * determined by the used_after_list, the items in the list |
| 1263 | * are kind of sorted, so could optimise the insert_set operations. |
| 1264 | *) |
| 1265 | |
| 1266 | |
| 1267 | (* r(ule), c(element in C code), e(nvironment) *) |
| 1268 | |
| 1269 | let merge_env new_e old_e = |
| 1270 | List.iter |
| 1271 | (function (e,rules) -> |
| 1272 | let _ = update_env old_e e rules in ()) new_e; |
| 1273 | old_e |
| 1274 | |
| 1275 | let contains_binding e (_,(r,m),_) = |
| 1276 | try |
| 1277 | let _ = List.find (function ((re, rm), _) -> r =*= re && m =$= rm) e in |
| 1278 | true |
| 1279 | with Not_found -> false |
| 1280 | |
| 1281 | exception Exited |
| 1282 | |
| 1283 | let python_application mv ve script_vars r = |
| 1284 | let mv = |
| 1285 | List.map |
| 1286 | (function |
| 1287 | ((Some x,None),y,z) -> (x,y,z) |
| 1288 | | _ -> |
| 1289 | failwith |
| 1290 | (Printf.sprintf "unexpected ast metavar in rule %s" |
| 1291 | r.scr_rule_info.rulename)) |
| 1292 | mv in |
| 1293 | try |
| 1294 | Pycocci.build_classes (List.map (function (x,y) -> x) ve); |
| 1295 | Pycocci.construct_variables mv ve; |
| 1296 | Pycocci.construct_script_variables script_vars; |
| 1297 | let _ = Pycocci.pyrun_simplestring (local_python_code ^r.script_code) in |
| 1298 | if !Pycocci.exited |
| 1299 | then raise Exited |
| 1300 | else if !Pycocci.inc_match |
| 1301 | then Some (Pycocci.retrieve_script_variables script_vars) |
| 1302 | else None |
| 1303 | with Pycocci.Pycocciexception -> |
| 1304 | (pr2 ("Failure in " ^ r.scr_rule_info.rulename); |
| 1305 | raise Pycocci.Pycocciexception) |
| 1306 | |
| 1307 | let ocaml_application mv ve script_vars r = |
| 1308 | try |
| 1309 | let script_vals = |
| 1310 | Run_ocamlcocci.run mv ve script_vars |
| 1311 | r.scr_rule_info.rulename r.script_code in |
| 1312 | if !Coccilib.exited |
| 1313 | then raise Exited |
| 1314 | else if !Coccilib.inc_match |
| 1315 | then Some script_vals |
| 1316 | else None |
| 1317 | with e -> (pr2 ("Failure in " ^ r.scr_rule_info.rulename); raise e) |
| 1318 | |
| 1319 | (* returns Left in case of dependency failure, Right otherwise *) |
| 1320 | let apply_script_rule r cache newes e rules_that_have_matched |
| 1321 | rules_that_have_ever_matched script_application = |
| 1322 | Common.profile_code r.language (fun () -> |
| 1323 | show_or_not_scr_rule_name r.scr_rule_info.ruleid; |
| 1324 | if not(interpret_dependencies rules_that_have_matched |
| 1325 | !rules_that_have_ever_matched r.scr_rule_info.dependencies) |
| 1326 | then |
| 1327 | begin |
| 1328 | print_dependencies "dependencies for script not satisfied:" |
| 1329 | rules_that_have_matched |
| 1330 | !rules_that_have_ever_matched r.scr_rule_info.dependencies; |
| 1331 | show_or_not_binding "in environment" e; |
| 1332 | (cache, safe_update_env newes e rules_that_have_matched) |
| 1333 | end |
| 1334 | else |
| 1335 | begin |
| 1336 | let (_, mv, script_vars, _) = r.scr_ast_rule in |
| 1337 | let ve = |
| 1338 | (List.map (function (n,v) -> (("virtual",n),Ast_c.MetaIdVal (v,[]))) |
| 1339 | !Flag.defined_virtual_env) @ e in |
| 1340 | let not_bound x = not (contains_binding ve x) in |
| 1341 | (match List.filter not_bound mv with |
| 1342 | [] -> |
| 1343 | let relevant_bindings = |
| 1344 | List.filter |
| 1345 | (function ((re,rm),_) -> |
| 1346 | List.exists (function (_,(r,m),_) -> r =*= re && m =$= rm) mv) |
| 1347 | e in |
| 1348 | (try |
| 1349 | match List.assoc relevant_bindings cache with |
| 1350 | None -> (cache,newes) |
| 1351 | | Some script_vals -> |
| 1352 | print_dependencies |
| 1353 | "dependencies for script satisfied, but cached:" |
| 1354 | rules_that_have_matched |
| 1355 | !rules_that_have_ever_matched |
| 1356 | r.scr_rule_info.dependencies; |
| 1357 | show_or_not_binding "in" e; |
| 1358 | (* env might be bigger than what was cached against, so have to |
| 1359 | merge with newes anyway *) |
| 1360 | let new_e = (List.combine script_vars script_vals) @ e in |
| 1361 | let new_e = |
| 1362 | new_e +> |
| 1363 | List.filter |
| 1364 | (fun (s,v) -> List.mem s r.scr_rule_info.used_after) in |
| 1365 | (cache,update_env newes new_e rules_that_have_matched) |
| 1366 | with Not_found -> |
| 1367 | begin |
| 1368 | print_dependencies "dependencies for script satisfied:" |
| 1369 | rules_that_have_matched |
| 1370 | !rules_that_have_ever_matched |
| 1371 | r.scr_rule_info.dependencies; |
| 1372 | show_or_not_binding "in" e; |
| 1373 | match script_application mv ve script_vars r with |
| 1374 | None -> |
| 1375 | (* failure means we should drop e, no new bindings *) |
| 1376 | (((relevant_bindings,None) :: cache), newes) |
| 1377 | | Some script_vals -> |
| 1378 | let script_vals = |
| 1379 | List.map (function x -> Ast_c.MetaIdVal(x,[])) |
| 1380 | script_vals in |
| 1381 | let new_e = (List.combine script_vars script_vals) @ e in |
| 1382 | let new_e = |
| 1383 | new_e +> |
| 1384 | List.filter |
| 1385 | (fun (s,v) -> List.mem s r.scr_rule_info.used_after) in |
| 1386 | r.scr_rule_info.was_matched := true; |
| 1387 | (((relevant_bindings,Some script_vals) :: cache), |
| 1388 | update_env newes new_e |
| 1389 | (r.scr_rule_info.rulename :: rules_that_have_matched)) |
| 1390 | end) |
| 1391 | | unbound -> |
| 1392 | (if !Flag_cocci.show_dependencies |
| 1393 | then |
| 1394 | let m2c (_,(r,x),_) = r^"."^x in |
| 1395 | pr2 (Printf.sprintf "script not applied: %s not bound" |
| 1396 | (String.concat ", " (List.map m2c unbound)))); |
| 1397 | let e = |
| 1398 | e +> |
| 1399 | List.filter (fun (s,v) -> List.mem s r.scr_rule_info.used_after) in |
| 1400 | (cache, update_env newes e rules_that_have_matched)) |
| 1401 | end) |
| 1402 | |
| 1403 | let rec apply_cocci_rule r rules_that_have_ever_matched es |
| 1404 | (ccs:file_info list ref) = |
| 1405 | Common.profile_code r.rule_info.rulename (fun () -> |
| 1406 | show_or_not_rule_name r.ast_rule r.rule_info.ruleid; |
| 1407 | show_or_not_ctl_text r.ctl r.ast_rule r.rule_info.ruleid; |
| 1408 | |
| 1409 | let reorganized_env = |
| 1410 | reassociate_positions r.free_vars r.negated_pos_vars !es in |
| 1411 | |
| 1412 | (* looping over the environments *) |
| 1413 | let (_,newes (* envs for next round/rule *)) = |
| 1414 | List.fold_left |
| 1415 | (function (cache,newes) -> |
| 1416 | function ((e,rules_that_have_matched),relevant_bindings) -> |
| 1417 | if not(interpret_dependencies rules_that_have_matched |
| 1418 | !rules_that_have_ever_matched |
| 1419 | r.rule_info.dependencies) |
| 1420 | then |
| 1421 | begin |
| 1422 | print_dependencies |
| 1423 | ("dependencies for rule "^r.rule_info.rulename^ |
| 1424 | " not satisfied:") |
| 1425 | rules_that_have_matched |
| 1426 | !rules_that_have_ever_matched r.rule_info.dependencies; |
| 1427 | show_or_not_binding "in environment" e; |
| 1428 | (cache, |
| 1429 | update_env newes |
| 1430 | (e +> |
| 1431 | List.filter |
| 1432 | (fun (s,v) -> List.mem s r.rule_info.used_after)) |
| 1433 | rules_that_have_matched) |
| 1434 | end |
| 1435 | else |
| 1436 | let new_bindings = |
| 1437 | try List.assoc relevant_bindings cache |
| 1438 | with |
| 1439 | Not_found -> |
| 1440 | print_dependencies |
| 1441 | ("dependencies for rule "^r.rule_info.rulename^ |
| 1442 | " satisfied:") |
| 1443 | rules_that_have_matched |
| 1444 | !rules_that_have_ever_matched |
| 1445 | r.rule_info.dependencies; |
| 1446 | show_or_not_binding "in" e; |
| 1447 | show_or_not_binding "relevant in" relevant_bindings; |
| 1448 | |
| 1449 | (* applying the rule *) |
| 1450 | (match r.ruletype with |
| 1451 | Ast_cocci.Normal -> |
| 1452 | (* looping over the functions and toplevel elements in |
| 1453 | .c and .h *) |
| 1454 | List.rev |
| 1455 | (concat_headers_and_c !ccs +> |
| 1456 | List.fold_left (fun children_e (c,f) -> |
| 1457 | if c.flow <> None |
| 1458 | then |
| 1459 | (* does also some side effects on c and r *) |
| 1460 | let processed = |
| 1461 | process_a_ctl_a_env_a_toplevel r |
| 1462 | relevant_bindings c f in |
| 1463 | match processed with |
| 1464 | | None -> children_e |
| 1465 | | Some newbindings -> |
| 1466 | newbindings +> |
| 1467 | List.fold_left |
| 1468 | (fun children_e newbinding -> |
| 1469 | if List.mem newbinding children_e |
| 1470 | then children_e |
| 1471 | else newbinding :: children_e) |
| 1472 | children_e |
| 1473 | else children_e) |
| 1474 | []) |
| 1475 | | Ast_cocci.Generated -> |
| 1476 | process_a_generated_a_env_a_toplevel r |
| 1477 | relevant_bindings !ccs; |
| 1478 | []) in |
| 1479 | |
| 1480 | let old_bindings_to_keep = |
| 1481 | Common.nub |
| 1482 | (e +> |
| 1483 | List.filter |
| 1484 | (fun (s,v) -> List.mem s r.rule_info.used_after)) in |
| 1485 | let new_e = |
| 1486 | if null new_bindings |
| 1487 | then |
| 1488 | begin |
| 1489 | (*use the old bindings, specialized to the used_after_list*) |
| 1490 | if !Flag_ctl.partial_match |
| 1491 | then |
| 1492 | printf |
| 1493 | "Empty list of bindings, I will restart from old env\n"; |
| 1494 | [(old_bindings_to_keep,rules_that_have_matched)] |
| 1495 | end |
| 1496 | else |
| 1497 | (* combine the new bindings with the old ones, and |
| 1498 | specialize to the used_after_list *) |
| 1499 | let old_variables = List.map fst old_bindings_to_keep in |
| 1500 | (* have to explicitly discard the inherited variables |
| 1501 | because we want the inherited value of the positions |
| 1502 | variables not the extended one created by |
| 1503 | reassociate_positions. want to reassociate freshly |
| 1504 | according to the free variables of each rule. *) |
| 1505 | let new_bindings_to_add = |
| 1506 | Common.nub |
| 1507 | (new_bindings +> |
| 1508 | List.map |
| 1509 | (List.filter |
| 1510 | (function |
| 1511 | (* see comment before combine_pos *) |
| 1512 | (s,Ast_c.MetaPosValList []) -> false |
| 1513 | | (s,v) -> |
| 1514 | List.mem s r.rule_info.used_after && |
| 1515 | not (List.mem s old_variables)))) in |
| 1516 | List.map |
| 1517 | (function new_binding_to_add -> |
| 1518 | (List.sort compare |
| 1519 | (Common.union_set |
| 1520 | old_bindings_to_keep new_binding_to_add), |
| 1521 | r.rule_info.rulename::rules_that_have_matched)) |
| 1522 | new_bindings_to_add in |
| 1523 | ((relevant_bindings,new_bindings)::cache, |
| 1524 | Common.profile_code "merge_env" (function _ -> |
| 1525 | merge_env new_e newes))) |
| 1526 | ([],init_env()) reorganized_env in (* end iter es *) |
| 1527 | if !(r.rule_info.was_matched) |
| 1528 | then Common.push2 r.rule_info.rulename rules_that_have_ever_matched; |
| 1529 | |
| 1530 | es := end_env newes; |
| 1531 | |
| 1532 | (* apply the tagged modifs and reparse *) |
| 1533 | if not !Flag.sgrep_mode2 |
| 1534 | then ccs := rebuild_info_c_and_headers !ccs r.isexp) |
| 1535 | |
| 1536 | and reassociate_positions free_vars negated_pos_vars envs = |
| 1537 | (* issues: isolate the bindings that are relevant to a given rule. |
| 1538 | separate out the position variables |
| 1539 | associate all of the position variables for a given set of relevant |
| 1540 | normal variable bindings with each set of relevant normal variable |
| 1541 | bindings. Goal: if eg if@p (E) matches in two places, then both inherited |
| 1542 | occurrences of E should see both bindings of p, not just its own. |
| 1543 | Otherwise, a position constraint for something that matches in two |
| 1544 | places will never be useful, because the position can always be |
| 1545 | different from the other one. *) |
| 1546 | let relevant = |
| 1547 | List.map |
| 1548 | (function (e,_) -> |
| 1549 | List.filter (function (x,_) -> List.mem x free_vars) e) |
| 1550 | envs in |
| 1551 | let splitted_relevant = |
| 1552 | (* separate the relevant variables into the non-position ones and the |
| 1553 | position ones *) |
| 1554 | List.map |
| 1555 | (function r -> |
| 1556 | List.fold_left |
| 1557 | (function (non_pos,pos) -> |
| 1558 | function (v,_) as x -> |
| 1559 | if List.mem v negated_pos_vars |
| 1560 | then (non_pos,x::pos) |
| 1561 | else (x::non_pos,pos)) |
| 1562 | ([],[]) r) |
| 1563 | relevant in |
| 1564 | let splitted_relevant = |
| 1565 | List.map |
| 1566 | (function (non_pos,pos) -> |
| 1567 | (List.sort compare non_pos,List.sort compare pos)) |
| 1568 | splitted_relevant in |
| 1569 | let non_poss = |
| 1570 | List.fold_left |
| 1571 | (function non_pos -> |
| 1572 | function (np,_) -> |
| 1573 | if List.mem np non_pos then non_pos else np::non_pos) |
| 1574 | [] splitted_relevant in |
| 1575 | let extended_relevant = |
| 1576 | (* extend the position variables with the values found at other identical |
| 1577 | variable bindings *) |
| 1578 | List.map |
| 1579 | (function non_pos -> |
| 1580 | let others = |
| 1581 | List.filter |
| 1582 | (function (other_non_pos,other_pos) -> |
| 1583 | (* do we want equal? or just somehow compatible? eg non_pos |
| 1584 | binds only E, but other_non_pos binds both E and E1 *) |
| 1585 | non_pos =*= other_non_pos) |
| 1586 | splitted_relevant in |
| 1587 | (non_pos, |
| 1588 | List.sort compare |
| 1589 | (non_pos @ |
| 1590 | (combine_pos negated_pos_vars |
| 1591 | (List.map (function (_,x) -> x) others))))) |
| 1592 | non_poss in |
| 1593 | List.combine envs |
| 1594 | (List.map (function (non_pos,_) -> List.assoc non_pos extended_relevant) |
| 1595 | splitted_relevant) |
| 1596 | |
| 1597 | (* If the negated posvar is not bound at all, this function will |
| 1598 | nevertheless bind it to []. If we get rid of these bindings, then the |
| 1599 | matching of the term the position variable with the constraints will fail |
| 1600 | because some variables are unbound. So we let the binding be [] and then |
| 1601 | we will have to clean these up afterwards. This should be the only way |
| 1602 | that a position variable can have an empty binding. *) |
| 1603 | and combine_pos negated_pos_vars others = |
| 1604 | List.map |
| 1605 | (function posvar -> |
| 1606 | let positions = |
| 1607 | List.sort compare |
| 1608 | (List.fold_left |
| 1609 | (function positions -> |
| 1610 | function other_list -> |
| 1611 | try |
| 1612 | match List.assoc posvar other_list with |
| 1613 | Ast_c.MetaPosValList l1 -> |
| 1614 | Common.union_set l1 positions |
| 1615 | | _ -> failwith "bad value for a position variable" |
| 1616 | with Not_found -> positions) |
| 1617 | [] others) in |
| 1618 | (posvar,Ast_c.MetaPosValList positions)) |
| 1619 | negated_pos_vars |
| 1620 | |
| 1621 | and process_a_generated_a_env_a_toplevel2 r env = function |
| 1622 | [cfile] -> |
| 1623 | let free_vars = |
| 1624 | List.filter |
| 1625 | (function |
| 1626 | (rule,_) when rule =$= r.rule_info.rulename -> false |
| 1627 | | (_,"ARGS") -> false |
| 1628 | | _ -> true) |
| 1629 | r.free_vars in |
| 1630 | let env_domain = List.map (function (nm,vl) -> nm) env in |
| 1631 | let metavars = |
| 1632 | List.filter |
| 1633 | (function md -> |
| 1634 | let (rl,_) = Ast_cocci.get_meta_name md in rl =$= r.rule_info.rulename) |
| 1635 | r.metavars in |
| 1636 | if Common.include_set free_vars env_domain |
| 1637 | then Unparse_hrule.pp_rule metavars r.ast_rule env cfile.full_fname |
| 1638 | | _ -> failwith "multiple files not supported" |
| 1639 | |
| 1640 | and process_a_generated_a_env_a_toplevel rule env ccs = |
| 1641 | Common.profile_code "process_a_ctl_a_env_a_toplevel" |
| 1642 | (fun () -> process_a_generated_a_env_a_toplevel2 rule env ccs) |
| 1643 | |
| 1644 | (* does side effects on C ast and on Cocci info rule *) |
| 1645 | and process_a_ctl_a_env_a_toplevel2 r e c f = |
| 1646 | indent_do (fun () -> |
| 1647 | show_or_not_celem "trying" c.ast_c; |
| 1648 | Flag.currentfile := Some (f ^ ":" ^get_celem c.ast_c); |
| 1649 | match (r.ctl,c.ast_c) with |
| 1650 | ((Asttoctl2.NONDECL ctl,t),Ast_c.Declaration _) -> None |
| 1651 | | ((Asttoctl2.NONDECL ctl,t), _) |
| 1652 | | ((Asttoctl2.CODE ctl,t), _) -> |
| 1653 | let ctl = (ctl,t) in (* ctl and other info *) |
| 1654 | let (trans_info, returned_any_states, inherited_bindings, newbindings) = |
| 1655 | Common.save_excursion Flag_ctl.loop_in_src_code (fun () -> |
| 1656 | Flag_ctl.loop_in_src_code := |
| 1657 | !Flag_ctl.loop_in_src_code||c.contain_loop; |
| 1658 | |
| 1659 | (***************************************) |
| 1660 | (* !Main point! The call to the engine *) |
| 1661 | (***************************************) |
| 1662 | let model_ctl = |
| 1663 | CCI.model_for_ctl r.dropped_isos (Common.some c.flow) e |
| 1664 | in CCI.mysat model_ctl ctl |
| 1665 | (r.rule_info.rulename, r.rule_info.used_after, e)) |
| 1666 | in |
| 1667 | if not returned_any_states |
| 1668 | then None |
| 1669 | else |
| 1670 | begin |
| 1671 | show_or_not_celem "found match in" c.ast_c; |
| 1672 | show_or_not_trans_info trans_info; |
| 1673 | List.iter (show_or_not_binding "out") newbindings; |
| 1674 | |
| 1675 | r.rule_info.was_matched := true; |
| 1676 | |
| 1677 | if not (null trans_info) && |
| 1678 | not (!Flag.sgrep_mode2 && not !Flag_cocci.show_diff) |
| 1679 | then |
| 1680 | begin |
| 1681 | c.was_modified := true; |
| 1682 | try |
| 1683 | (* les "more than one var in a decl" et "already tagged token" |
| 1684 | * font crasher coccinelle. Si on a 5 fichiers, donc on a 5 |
| 1685 | * failed. Le try limite le scope des crashes pendant la |
| 1686 | * trasformation au fichier concerne. *) |
| 1687 | |
| 1688 | (* modify ast via side effect *) |
| 1689 | ignore |
| 1690 | (Transformation_c.transform r.rule_info.rulename |
| 1691 | r.dropped_isos |
| 1692 | inherited_bindings trans_info (Common.some c.flow)); |
| 1693 | with Timeout -> raise Timeout | UnixExit i -> raise (UnixExit i) |
| 1694 | end; |
| 1695 | |
| 1696 | Some (List.map (function x -> x@inherited_bindings) newbindings) |
| 1697 | end |
| 1698 | ) |
| 1699 | |
| 1700 | and process_a_ctl_a_env_a_toplevel a b c f= |
| 1701 | Common.profile_code "process_a_ctl_a_env_a_toplevel" |
| 1702 | (fun () -> process_a_ctl_a_env_a_toplevel2 a b c f) |
| 1703 | |
| 1704 | |
| 1705 | let rec bigloop2 rs (ccs: file_info list) = |
| 1706 | let init_es = [(Ast_c.emptyMetavarsBinding,[])] in |
| 1707 | let es = ref init_es in |
| 1708 | let ccs = ref ccs in |
| 1709 | let rules_that_have_ever_matched = ref [] in |
| 1710 | |
| 1711 | (try |
| 1712 | |
| 1713 | (* looping over the rules *) |
| 1714 | rs +> List.iter (fun r -> |
| 1715 | match r with |
| 1716 | InitialScriptRuleCocciInfo r | FinalScriptRuleCocciInfo r -> () |
| 1717 | | ScriptRuleCocciInfo r -> |
| 1718 | if !Flag_cocci.show_ctl_text then begin |
| 1719 | Common.pr_xxxxxxxxxxxxxxxxx (); |
| 1720 | pr ("script: " ^ r.language); |
| 1721 | Common.pr_xxxxxxxxxxxxxxxxx (); |
| 1722 | |
| 1723 | adjust_pp_with_indent (fun () -> |
| 1724 | Format.force_newline(); |
| 1725 | let (l,mv,script_vars,code) = r.scr_ast_rule in |
| 1726 | let nm = r.scr_rule_info.rulename in |
| 1727 | let deps = r.scr_rule_info.dependencies in |
| 1728 | Pretty_print_cocci.unparse |
| 1729 | (Ast_cocci.ScriptRule (nm,l,deps,mv,script_vars,code))); |
| 1730 | end; |
| 1731 | |
| 1732 | (*pr2 (List.hd(cmd_to_list "free -m | grep Mem"));*) |
| 1733 | if !Flag.show_misc then print_endline "RESULT ="; |
| 1734 | |
| 1735 | let (_, newes) = |
| 1736 | List.fold_left |
| 1737 | (function (cache, newes) -> |
| 1738 | function (e, rules_that_have_matched) -> |
| 1739 | match r.language with |
| 1740 | "python" -> |
| 1741 | apply_script_rule r cache newes e rules_that_have_matched |
| 1742 | rules_that_have_ever_matched python_application |
| 1743 | | "ocaml" -> |
| 1744 | apply_script_rule r cache newes e rules_that_have_matched |
| 1745 | rules_that_have_ever_matched ocaml_application |
| 1746 | | "test" -> |
| 1747 | concat_headers_and_c !ccs +> List.iter (fun (c,_) -> |
| 1748 | if c.flow <> None |
| 1749 | then |
| 1750 | Printf.printf "Flow: %s\r\nFlow!\r\n%!" c.fullstring); |
| 1751 | (cache, newes) |
| 1752 | | _ -> |
| 1753 | Printf.printf "Unknown language: %s\n" r.language; |
| 1754 | (cache, newes)) |
| 1755 | ([],init_env()) !es in |
| 1756 | |
| 1757 | (if !(r.scr_rule_info.was_matched) |
| 1758 | then |
| 1759 | Common.push2 r.scr_rule_info.rulename rules_that_have_ever_matched); |
| 1760 | |
| 1761 | (* just newes can't work, because if one does include_match false |
| 1762 | on everything that binds a variable, then nothing is left *) |
| 1763 | es := (*newes*) |
| 1764 | (if Hashtbl.length newes = 0 then init_es else end_env newes) |
| 1765 | | CocciRuleCocciInfo r -> |
| 1766 | apply_cocci_rule r rules_that_have_ever_matched |
| 1767 | es ccs) |
| 1768 | with Exited -> ()); |
| 1769 | |
| 1770 | if !Flag.sgrep_mode2 |
| 1771 | then begin |
| 1772 | (* sgrep can lead to code that is not parsable, but we must |
| 1773 | * still call rebuild_info_c_and_headers to pretty print the |
| 1774 | * action (MINUS), so that later the diff will show what was |
| 1775 | * matched by sgrep. But we don't want the parsing error message |
| 1776 | * hence the following flag setting. So this code propably |
| 1777 | * will generate a NotParsedCorrectly for the matched parts |
| 1778 | * and the very final pretty print and diff will work |
| 1779 | *) |
| 1780 | Flag_parsing_c.verbose_parsing := false; |
| 1781 | ccs := rebuild_info_c_and_headers !ccs false |
| 1782 | end; |
| 1783 | !ccs (* return final C asts *) |
| 1784 | |
| 1785 | let bigloop a b = |
| 1786 | Common.profile_code "bigloop" (fun () -> bigloop2 a b) |
| 1787 | |
| 1788 | type init_final = Initial | Final |
| 1789 | |
| 1790 | let initial_final_bigloop2 ty rebuild r = |
| 1791 | if !Flag_cocci.show_ctl_text then |
| 1792 | begin |
| 1793 | Common.pr_xxxxxxxxxxxxxxxxx (); |
| 1794 | pr ((match ty with Initial -> "initial" | Final -> "final") ^ ": " ^ |
| 1795 | r.language); |
| 1796 | Common.pr_xxxxxxxxxxxxxxxxx (); |
| 1797 | |
| 1798 | adjust_pp_with_indent (fun () -> |
| 1799 | Format.force_newline(); |
| 1800 | Pretty_print_cocci.unparse(rebuild r.scr_ast_rule r.scr_rule_info.dependencies)); |
| 1801 | end; |
| 1802 | |
| 1803 | match r.language with |
| 1804 | "python" -> |
| 1805 | (* include_match makes no sense in an initial or final rule, although |
| 1806 | we have no way to prevent it *) |
| 1807 | let newes = init_env() in |
| 1808 | let _ = apply_script_rule r [] newes [] [] (ref []) python_application in |
| 1809 | () |
| 1810 | | "ocaml" when ty = Initial -> () (* nothing to do *) |
| 1811 | | "ocaml" -> |
| 1812 | (* include_match makes no sense in an initial or final rule, although |
| 1813 | we have no way to prevent it *) |
| 1814 | let newes = init_env() in |
| 1815 | let _ = apply_script_rule r [] newes [] [] (ref []) ocaml_application in |
| 1816 | () |
| 1817 | | _ -> |
| 1818 | failwith ("Unknown language for initial/final script: "^ |
| 1819 | r.language) |
| 1820 | |
| 1821 | let initial_final_bigloop a b c = |
| 1822 | Common.profile_code "initial_final_bigloop" |
| 1823 | (fun () -> initial_final_bigloop2 a b c) |
| 1824 | |
| 1825 | (*****************************************************************************) |
| 1826 | (* The main functions *) |
| 1827 | (*****************************************************************************) |
| 1828 | |
| 1829 | let pre_engine2 (coccifile, isofile) = |
| 1830 | show_or_not_cocci coccifile isofile; |
| 1831 | Pycocci.set_coccifile coccifile; |
| 1832 | |
| 1833 | let isofile = |
| 1834 | if not (Common.lfile_exists isofile) |
| 1835 | then begin |
| 1836 | pr2 ("warning: Can't find default iso file: " ^ isofile); |
| 1837 | None |
| 1838 | end |
| 1839 | else Some isofile in |
| 1840 | |
| 1841 | (* useful opti when use -dir *) |
| 1842 | let (metavars,astcocci, |
| 1843 | free_var_lists,negated_pos_lists,used_after_lists, |
| 1844 | positions_lists,(toks,_,_)) = sp_of_file coccifile isofile in |
| 1845 | |
| 1846 | let ctls = ctls_of_ast astcocci used_after_lists positions_lists in |
| 1847 | |
| 1848 | g_contain_typedmetavar := sp_contain_typed_metavar astcocci; |
| 1849 | |
| 1850 | check_macro_in_sp_and_adjust toks; |
| 1851 | |
| 1852 | show_or_not_ctl_tex astcocci ctls; |
| 1853 | |
| 1854 | let cocci_infos = |
| 1855 | prepare_cocci ctls free_var_lists negated_pos_lists |
| 1856 | used_after_lists positions_lists metavars astcocci in |
| 1857 | |
| 1858 | let used_languages = |
| 1859 | List.fold_left |
| 1860 | (function languages -> |
| 1861 | function |
| 1862 | ScriptRuleCocciInfo(r) -> |
| 1863 | if List.mem r.language languages then |
| 1864 | languages |
| 1865 | else |
| 1866 | r.language::languages |
| 1867 | | _ -> languages) |
| 1868 | [] cocci_infos in |
| 1869 | |
| 1870 | let runrule r = |
| 1871 | let rlang = r.language in |
| 1872 | let rname = r.scr_rule_info.rulename in |
| 1873 | try |
| 1874 | let _ = List.assoc (rlang,rname) !Iteration.initialization_stack in |
| 1875 | () |
| 1876 | with Not_found -> |
| 1877 | begin |
| 1878 | Iteration.initialization_stack := |
| 1879 | ((rlang,rname),!Flag.defined_virtual_rules) :: |
| 1880 | !Iteration.initialization_stack; |
| 1881 | initial_final_bigloop Initial |
| 1882 | (fun (x,_,_,y) -> fun deps -> |
| 1883 | Ast_cocci.InitialScriptRule(rname,x,deps,y)) |
| 1884 | r |
| 1885 | end in |
| 1886 | |
| 1887 | let initialized_languages = |
| 1888 | List.fold_left |
| 1889 | (function languages -> |
| 1890 | function |
| 1891 | InitialScriptRuleCocciInfo(r) -> |
| 1892 | let rlang = r.language in |
| 1893 | (if List.mem rlang languages |
| 1894 | then failwith ("double initializer found for "^rlang)); |
| 1895 | if interpret_dependencies [] [] r.scr_rule_info.dependencies |
| 1896 | then begin runrule r; rlang::languages end |
| 1897 | else languages |
| 1898 | | _ -> languages) |
| 1899 | [] cocci_infos in |
| 1900 | |
| 1901 | let uninitialized_languages = |
| 1902 | List.filter |
| 1903 | (fun used -> not (List.mem used initialized_languages)) |
| 1904 | used_languages in |
| 1905 | |
| 1906 | List.iter |
| 1907 | (fun lgg -> |
| 1908 | let rule_info = |
| 1909 | {rulename = ""; |
| 1910 | dependencies = Ast_cocci.NoDep; |
| 1911 | used_after = []; |
| 1912 | ruleid = (-1); |
| 1913 | was_matched = ref false;} in |
| 1914 | runrule (make_init lgg "" rule_info)) |
| 1915 | uninitialized_languages; |
| 1916 | |
| 1917 | (cocci_infos,toks) |
| 1918 | |
| 1919 | let pre_engine a = |
| 1920 | Common.profile_code "pre_engine" (fun () -> pre_engine2 a) |
| 1921 | |
| 1922 | let full_engine2 (cocci_infos,toks) cfiles = |
| 1923 | |
| 1924 | show_or_not_cfiles cfiles; |
| 1925 | |
| 1926 | (* optimisation allowing to launch coccinelle on all the drivers *) |
| 1927 | if !Flag_cocci.worth_trying_opt && not (worth_trying cfiles toks) |
| 1928 | then |
| 1929 | begin |
| 1930 | (match toks with |
| 1931 | None -> () |
| 1932 | | Some toks -> |
| 1933 | pr2 ("No matches found for " ^ (Common.join " " toks) |
| 1934 | ^ "\nSkipping:" ^ (Common.join " " cfiles))); |
| 1935 | cfiles +> List.map (fun s -> s, None) |
| 1936 | end |
| 1937 | else |
| 1938 | begin |
| 1939 | |
| 1940 | if !Flag.show_misc then Common.pr_xxxxxxxxxxxxxxxxx(); |
| 1941 | if !Flag.show_misc then pr "let's go"; |
| 1942 | if !Flag.show_misc then Common.pr_xxxxxxxxxxxxxxxxx(); |
| 1943 | |
| 1944 | if !Flag_cocci.show_binding_in_out |
| 1945 | then |
| 1946 | begin |
| 1947 | (match !Flag.defined_virtual_rules with |
| 1948 | [] -> () |
| 1949 | | l -> pr (Printf.sprintf "Defined virtual rules: %s" |
| 1950 | (String.concat " " l))); |
| 1951 | List.iter |
| 1952 | (function (v,vl) -> |
| 1953 | pr (Printf.sprintf "%s = %s" v vl)) |
| 1954 | !Flag.defined_virtual_env; |
| 1955 | Common.pr_xxxxxxxxxxxxxxxxx() |
| 1956 | end; |
| 1957 | |
| 1958 | let choose_includes = |
| 1959 | match !Flag_cocci.include_options with |
| 1960 | Flag_cocci.I_UNSPECIFIED -> |
| 1961 | if !g_contain_typedmetavar |
| 1962 | then Flag_cocci.I_NORMAL_INCLUDES |
| 1963 | else Flag_cocci.I_NO_INCLUDES |
| 1964 | | x -> x in |
| 1965 | let c_infos = prepare_c cfiles choose_includes in |
| 1966 | |
| 1967 | (* ! the big loop ! *) |
| 1968 | let c_infos' = bigloop cocci_infos c_infos in |
| 1969 | |
| 1970 | if !Flag.show_misc then Common.pr_xxxxxxxxxxxxxxxxx (); |
| 1971 | if !Flag.show_misc then pr "Finished"; |
| 1972 | if !Flag.show_misc then Common.pr_xxxxxxxxxxxxxxxxx (); |
| 1973 | if !Flag_ctl.graphical_trace then gen_pdf_graph (); |
| 1974 | |
| 1975 | c_infos' +> List.map (fun c_or_h -> |
| 1976 | if !(c_or_h.was_modified_once) |
| 1977 | then |
| 1978 | begin |
| 1979 | let outfile = |
| 1980 | Common.new_temp_file "cocci-output" ("-" ^ c_or_h.fname) in |
| 1981 | |
| 1982 | if c_or_h.fkind =*= Header |
| 1983 | then pr2 ("a header file was modified: " ^ c_or_h.fname); |
| 1984 | |
| 1985 | (* and now unparse everything *) |
| 1986 | cfile_of_program (for_unparser c_or_h.asts) outfile; |
| 1987 | |
| 1988 | show_or_not_diff c_or_h.fpath outfile; |
| 1989 | |
| 1990 | (c_or_h.fpath, |
| 1991 | if !Flag.sgrep_mode2 then None else Some outfile) |
| 1992 | end |
| 1993 | else (c_or_h.fpath, None)) |
| 1994 | end |
| 1995 | |
| 1996 | let full_engine a b = |
| 1997 | Common.profile_code "full_engine" |
| 1998 | (fun () -> let res = full_engine2 a b in (*Gc.print_stat stderr; *)res) |
| 1999 | |
| 2000 | let post_engine2 (cocci_infos,_) = |
| 2001 | List.iter |
| 2002 | (function ((language,_),virt_rules) -> |
| 2003 | Flag.defined_virtual_rules := virt_rules; |
| 2004 | let _ = |
| 2005 | List.fold_left |
| 2006 | (function languages -> |
| 2007 | function |
| 2008 | FinalScriptRuleCocciInfo(r) -> |
| 2009 | (if r.language = language && List.mem r.language languages |
| 2010 | then failwith ("double finalizer found for "^r.language)); |
| 2011 | initial_final_bigloop Final |
| 2012 | (fun (x,_,_,y) -> fun deps -> |
| 2013 | Ast_cocci.FinalScriptRule(r.scr_rule_info.rulename, |
| 2014 | x,deps,y)) |
| 2015 | r; |
| 2016 | r.language::languages |
| 2017 | | _ -> languages) |
| 2018 | [] cocci_infos in |
| 2019 | ()) |
| 2020 | !Iteration.initialization_stack |
| 2021 | |
| 2022 | let post_engine a = |
| 2023 | Common.profile_code "post_engine" (fun () -> post_engine2 a) |
| 2024 | |
| 2025 | (*****************************************************************************) |
| 2026 | (* check duplicate from result of full_engine *) |
| 2027 | (*****************************************************************************) |
| 2028 | |
| 2029 | let check_duplicate_modif2 xs = |
| 2030 | (* opti: let groups = Common.groupBy (fun (a,resa) (b,resb) -> a =$= b) xs *) |
| 2031 | if !Flag_cocci.verbose_cocci |
| 2032 | then pr2 ("Check duplication for " ^ i_to_s (List.length xs) ^ " files"); |
| 2033 | |
| 2034 | let groups = Common.group_assoc_bykey_eff xs in |
| 2035 | groups +> Common.map_filter (fun (file, xs) -> |
| 2036 | match xs with |
| 2037 | | [] -> raise (Impossible 162) |
| 2038 | | [res] -> Some (file, res) |
| 2039 | | res::xs -> |
| 2040 | match res with |
| 2041 | | None -> |
| 2042 | if not (List.for_all (fun res2 -> res2 =*= None) xs) |
| 2043 | then begin |
| 2044 | pr2 ("different modification result for " ^ file); |
| 2045 | None |
| 2046 | end |
| 2047 | else Some (file, None) |
| 2048 | | Some res -> |
| 2049 | if not(List.for_all (fun res2 -> |
| 2050 | match res2 with |
| 2051 | | None -> false |
| 2052 | | Some res2 -> |
| 2053 | let diff = Common.cmd_to_list ("diff -u -b -B "^res^" "^res2) |
| 2054 | in |
| 2055 | null diff |
| 2056 | ) xs) then begin |
| 2057 | pr2 ("different modification result for " ^ file); |
| 2058 | None |
| 2059 | end |
| 2060 | else Some (file, Some res) |
| 2061 | ) |
| 2062 | let check_duplicate_modif a = |
| 2063 | Common.profile_code "check_duplicate" (fun () -> check_duplicate_modif2 a) |
| 2064 | |