From 91eba41f0f6608eba3499d37eeaf609f7060fffe Mon Sep 17 00:00:00 2001 From: Coccinelle Date: Sun, 3 Oct 2010 13:56:42 +0200 Subject: [PATCH] Release coccinelle-0.1.3 ** Features: - help in building the configuration macro file. The -parse_c action now returns the 10 most frequent parsing errors. This give useful hints to extend standard.h. ** Bugfix: - positions no longer allowed on \(, \|, and \) - improved propagation of negation for isos in the presence of parens - convert Todos in flow graph construction to recoverable errors - fixed bug in treatment of when != true and when != false, to allow more than one of them per ... - improve parsing of typedef of function pointer. - improve typing. - parsing and typing support for old style C function declaration. - consider position variables as modifications when optimizing the translation into CTL of function definitions --- .#cocci.ml.1.290 | 1470 ++++++++++++ .cvsignore | 2 + .depend | 14 +- changes.txt | 21 + cocci.ml | 4 +- commitmsg | 26 +- commons/.depend | 104 +- commons/Makefile | 56 +- commons/common.ml | 302 ++- commons/common.mli | 75 +- commons/common_extra.ml | 16 +- commons/glimpse.ml | 76 +- commons/oarray.ml | 3 + commons/oarray.mli | 2 + commons/oassoc.ml | 12 +- commons/oassoc.mli | 6 + commons/ocollection.ml | 6 + commons/ocollection.mli | 2 + commons/{ => ocollection}/oassoc_buffer.ml | 44 +- commons/{ => ocollection}/oassoc_buffer.mli | 8 +- commons/{ => ocollection}/oassocb.ml | 3 + commons/{ => ocollection}/oassocbdb.ml | 70 +- commons/{ => ocollection}/oassocbdb.mli | 20 +- commons/ocollection/oassocbdb_string.ml | 171 ++ commons/ocollection/oassocbdb_string.mli | 41 + commons/{ => ocollection}/oassocdbm.ml | 13 + commons/{ => ocollection}/oassocdbm.mli | 2 + commons/{ => ocollection}/oassoch.ml | 4 + commons/{ => ocollection}/oassocid.ml | 4 + commons/{ => ocollection}/ograph2way.ml | 0 commons/{ => ocollection}/ograph2way.mli | 0 commons/{ => ocollection}/osetb.ml | 0 commons/{ => ocollection}/oseth.ml | 0 commons/{ => ocollection}/oseti.ml | 0 commons/{ => ocollection}/osetpt.ml | 0 copyright.txt | 2 +- ctl/.depend | 6 +- engine/.#Makefile.1.50 | 126 + engine/.#asttoctl2.ml.1.145 | 2311 ++++++++++++++++++ engine/.#asttoctl2.ml.1.147 | 2319 ++++++++++++++++++ engine/.depend | 11 + engine/Makefile | 2 +- engine/asttoctl2.ml | 33 +- engine/cocci_vs_c.ml | 6 + engine/cocci_vs_c.mli | 2 +- engine/lib_matcher_c.ml | 134 ++ engine/lib_matcher_c.mli | 21 + globals/config.ml | 2 +- globals/flag.ml | 1 - parsing_c/.depend | 65 +- parsing_c/Makefile | 5 +- parsing_c/ast_c.ml | 62 +- parsing_c/ast_to_flow.ml | 17 +- parsing_c/ast_to_flow.mli | 1 + parsing_c/cpp_ast_c.ml | 125 +- parsing_c/cpp_ast_c.mli | 33 +- parsing_c/flag_parsing_c.ml | 30 +- parsing_c/lexer_c.mll | 2 + parsing_c/lexer_parser.ml | 3 + parsing_c/lib_parsing_c.ml | 65 + parsing_c/parse_c.ml | 43 +- parsing_c/parse_c.mli | 4 +- parsing_c/parser_c.mly | 39 +- parsing_c/parsing_hacks.ml | 28 +- parsing_c/parsing_hacks.mli | 15 +- parsing_c/parsing_stat.ml | 58 +- parsing_c/pretty_print_c.ml | 58 +- parsing_c/pretty_print_c.mli | 5 + parsing_c/test_parsing_c.ml | 88 +- parsing_c/token_helpers.ml | 34 + parsing_c/token_helpers.mli | 3 + parsing_c/type_annoter_c.ml | 1141 ++++++--- parsing_c/type_annoter_c.mli | 54 +- parsing_c/type_c.ml | 309 +++ parsing_c/type_c.mli | 36 + parsing_c/visitor_c.ml | 102 +- parsing_c/visitor_c.mli | 2 + parsing_cocci/.#iso_pattern.ml.1.144 | 2334 +++++++++++++++++++ parsing_cocci/.#parse_cocci.ml.1.164 | 1566 +++++++++++++ parsing_cocci/.#type_infer.ml.1.55 | 359 +++ parsing_cocci/.depend | 10 +- parsing_cocci/iso_pattern.ml | 64 +- parsing_cocci/parse_cocci.ml | 6 +- parsing_cocci/type_infer.ml | 14 +- pycaml/Makefile | 9 +- python/coccilib/.cvsignore | 1 + python/coccilib/coccigui/.cvsignore | 1 + python/coccilib/output.py | 6 + tests/assert.c | 10 + tests/deftodo.c | 13 + tests/deftodo.cocci | 27 + tests/deftodo.res | 13 + tests/doubleswitch.c | 19 + tests/doubleswitch.cocci | 4 + tests/doubleswitch.res | 17 + tools/bridge.ml | 6 +- tools/distributed/.cvsignore | 2 + tools/distributed/spatch_linux_script | 2 +- 98 files changed, 13808 insertions(+), 655 deletions(-) create mode 100644 .#cocci.ml.1.290 rewrite commitmsg (94%) rename commons/{ => ocollection}/oassoc_buffer.ml (62%) rename commons/{ => ocollection}/oassoc_buffer.mli (91%) rename commons/{ => ocollection}/oassocb.ml (92%) rename commons/{ => ocollection}/oassocbdb.ml (62%) rename commons/{ => ocollection}/oassocbdb.mli (59%) create mode 100644 commons/ocollection/oassocbdb_string.ml create mode 100644 commons/ocollection/oassocbdb_string.mli rename commons/{ => ocollection}/oassocdbm.ml (88%) rename commons/{ => ocollection}/oassocdbm.mli (96%) rename commons/{ => ocollection}/oassoch.ml (95%) rename commons/{ => ocollection}/oassocid.ml (88%) rename commons/{ => ocollection}/ograph2way.ml (100%) rename commons/{ => ocollection}/ograph2way.mli (100%) rename commons/{ => ocollection}/osetb.ml (100%) rename commons/{ => ocollection}/oseth.ml (100%) rename commons/{ => ocollection}/oseti.ml (100%) rename commons/{ => ocollection}/osetpt.ml (100%) create mode 100644 engine/.#Makefile.1.50 create mode 100644 engine/.#asttoctl2.ml.1.145 create mode 100644 engine/.#asttoctl2.ml.1.147 create mode 100644 engine/lib_matcher_c.ml create mode 100644 engine/lib_matcher_c.mli rewrite parsing_c/type_annoter_c.mli (82%) create mode 100644 parsing_c/type_c.ml create mode 100644 parsing_c/type_c.mli create mode 100644 parsing_cocci/.#iso_pattern.ml.1.144 create mode 100644 parsing_cocci/.#parse_cocci.ml.1.164 create mode 100644 parsing_cocci/.#type_infer.ml.1.55 create mode 100644 python/coccilib/.cvsignore create mode 100644 python/coccilib/coccigui/.cvsignore create mode 100644 tests/assert.c create mode 100644 tests/deftodo.c create mode 100644 tests/deftodo.cocci create mode 100644 tests/deftodo.res create mode 100644 tests/doubleswitch.c create mode 100644 tests/doubleswitch.cocci create mode 100644 tests/doubleswitch.res create mode 100644 tools/distributed/.cvsignore diff --git a/.#cocci.ml.1.290 b/.#cocci.ml.1.290 new file mode 100644 index 0000000..6ab9293 --- /dev/null +++ b/.#cocci.ml.1.290 @@ -0,0 +1,1470 @@ +(* +* Copyright 2005-2008, Ecole des Mines de Nantes, University of Copenhagen +* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller +* This file is part of Coccinelle. +* +* Coccinelle is free software: you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation, according to version 2 of the License. +* +* Coccinelle is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with Coccinelle. If not, see . +* +* The authors reserve the right to distribute this or future versions of +* Coccinelle under other licenses. +*) + + +open Common + +module CCI = Ctlcocci_integration +module TAC = Type_annoter_c + +(*****************************************************************************) +(* This file is a kind of driver. It gathers all the important functions + * from coccinelle in one place. The different entities in coccinelle are: + * - files + * - astc + * - astcocci + * - flow (contain nodes) + * - ctl (contain rule_elems) + * This file contains functions to transform one in another. + *) +(*****************************************************************************) + +(* --------------------------------------------------------------------- *) +(* C related *) +(* --------------------------------------------------------------------- *) +let cprogram_of_file file = + let (program2, _stat) = Parse_c.parse_print_error_heuristic file in + program2 + +let cprogram_of_file_cached file = + let (program2, _stat) = Parse_c.parse_cache file in + if !Flag_cocci.ifdef_to_if + then + program2 +> Parse_c.with_program2 (fun asts -> + Cpp_ast_c.cpp_ifdef_statementize asts + ) + else program2 + +let cfile_of_program program2_with_ppmethod outf = + Unparse_c.pp_program program2_with_ppmethod outf + +(* for memoization, contains only one entry, the one for the SP *) +let _hparse = Hashtbl.create 101 +let _hctl = Hashtbl.create 101 + +(* --------------------------------------------------------------------- *) +(* Cocci related *) +(* --------------------------------------------------------------------- *) +let sp_of_file2 file iso = + Common.memoized _hparse (file, iso) (fun () -> + Parse_cocci.process file iso false) +let sp_of_file file iso = + Common.profile_code "parse cocci" (fun () -> sp_of_file2 file iso) + + +(* --------------------------------------------------------------------- *) +(* Flow related *) +(* --------------------------------------------------------------------- *) +let print_flow flow = + Ograph_extended.print_ograph_mutable flow "/tmp/test.dot" true + + +let ast_to_flow_with_error_messages2 x = + let flowopt = + try Ast_to_flow.ast_to_control_flow x + with Ast_to_flow.Error x -> + Ast_to_flow.report_error x; + None + in + flowopt +> do_option (fun flow -> + (* This time even if there is a deadcode, we still have a + * flow graph, so I can try the transformation and hope the + * deadcode will not bother us. + *) + try Ast_to_flow.deadcode_detection flow + with Ast_to_flow.Error (Ast_to_flow.DeadCode x) -> + Ast_to_flow.report_error (Ast_to_flow.DeadCode x); + ); + flowopt +let ast_to_flow_with_error_messages a = + Common.profile_code "flow" (fun () -> ast_to_flow_with_error_messages2 a) + + +(* --------------------------------------------------------------------- *) +(* Ctl related *) +(* --------------------------------------------------------------------- *) +let ctls_of_ast2 ast ua pos = + List.map2 + (function ast -> function (ua,pos) -> + List.combine + (if !Flag_cocci.popl + then Popl.popl ast + else Asttoctl2.asttoctl ast ua pos) + (Asttomember.asttomember ast ua)) + ast (List.combine ua pos) + +let ctls_of_ast ast ua = + Common.profile_code "asttoctl2" (fun () -> ctls_of_ast2 ast ua) + +(*****************************************************************************) +(* Some debugging functions *) +(*****************************************************************************) + +(* the inputs *) + +let show_or_not_cfile2 cfile = + if !Flag_cocci.show_c then begin + Common.pr2_xxxxxxxxxxxxxxxxx (); + pr2 ("processing C file: " ^ cfile); + Common.pr2_xxxxxxxxxxxxxxxxx (); + Common.command2 ("cat " ^ cfile); + end +let show_or_not_cfile a = + Common.profile_code "show_xxx" (fun () -> show_or_not_cfile2 a) + +let show_or_not_cfiles cfiles = List.iter show_or_not_cfile cfiles + + +let show_or_not_cocci2 coccifile isofile = + if !Flag_cocci.show_cocci then begin + Common.pr2_xxxxxxxxxxxxxxxxx (); + pr2 ("processing semantic patch file: " ^ coccifile); + isofile +> (fun s -> pr2 ("with isos from: " ^ s)); + Common.pr2_xxxxxxxxxxxxxxxxx (); + Common.command2 ("cat " ^ coccifile); + pr2 ""; + end +let show_or_not_cocci a b = + Common.profile_code "show_xxx" (fun () -> show_or_not_cocci2 a b) + + +(* the output *) + +let show_or_not_diff2 cfile outfile show_only_minus = + if !Flag_cocci.show_diff then begin + match Common.fst(Compare_c.compare_default cfile outfile) with + Compare_c.Correct -> () (* diff only in spacing, etc *) + | _ -> + (* may need --strip-trailing-cr under windows *) + pr2 "diff = "; + + let line = + match !Flag_parsing_c.diff_lines with + | None -> "diff -u -p " ^ cfile ^ " " ^ outfile + | Some n -> "diff -U "^n^" -p "^cfile^" "^outfile in + let xs = + let res = Common.cmd_to_list line in + match (!Flag.patch,res) with + (* create something that looks like the output of patch *) + (Some prefix,minus_file::plus_file::rest) -> + let drop_prefix file = + if prefix = "" + then "/"^file + else + (match Str.split (Str.regexp prefix) file with + [base_file] -> base_file + | _ -> failwith "prefix not found in the old file name") in + let diff_line = + match List.rev(Str.split (Str.regexp " ") line) with + new_file::old_file::cmdrev -> + if !Flag.sgrep_mode2 + then + String.concat " " + (List.rev ("/tmp/nothing" :: old_file :: cmdrev)) + else + let old_base_file = drop_prefix old_file in + String.concat " " + (List.rev + (("b"^old_base_file)::("a"^old_base_file)::cmdrev)) + | _ -> failwith "bad command" in + let (minus_line,plus_line) = + if !Flag.sgrep_mode2 + then (minus_file,plus_file) + else + match (Str.split (Str.regexp "[ \t]") minus_file, + Str.split (Str.regexp "[ \t]") plus_file) with + ("---"::old_file::old_rest,"+++"::new_file::new_rest) -> + let old_base_file = drop_prefix old_file in + (String.concat " " + ("---"::("a"^old_base_file)::old_rest), + String.concat " " + ("+++"::("b"^old_base_file)::new_rest)) + | (l1,l2) -> + failwith + (Printf.sprintf "bad diff header lines: %s %s" + (String.concat ":" l1) (String.concat ":" l2)) in + diff_line::minus_line::plus_line::rest + | _ -> res in + xs +> List.iter (fun s -> + if s =~ "^\\+" && show_only_minus + then () + else pr s) + end +let show_or_not_diff a b c = + Common.profile_code "show_xxx" (fun () -> show_or_not_diff2 a b c) + + +(* the derived input *) + +let show_or_not_ctl_tex2 astcocci ctls = + if !Flag_cocci.show_ctl_tex then begin + Ctltotex.totex ("/tmp/__cocci_ctl.tex") astcocci ctls; + Common.command2 ("cd /tmp; latex __cocci_ctl.tex; " ^ + "dvips __cocci_ctl.dvi -o __cocci_ctl.ps;" ^ + "gv __cocci_ctl.ps &"); + end +let show_or_not_ctl_tex a b = + Common.profile_code "show_xxx" (fun () -> show_or_not_ctl_tex2 a b) + + + +let show_or_not_rule_name ast rulenb = + if !Flag_cocci.show_ctl_text or !Flag.show_trying or + !Flag_cocci.show_transinfo or !Flag_cocci.show_binding_in_out + then + begin + let name = + match ast with + Ast_cocci.CocciRule (nm, (deps, drops, exists), x, _) -> nm + | _ -> i_to_s rulenb in + Common.pr_xxxxxxxxxxxxxxxxx (); + pr (name ^ " = "); + Common.pr_xxxxxxxxxxxxxxxxx () + end + +let show_or_not_scr_rule_name rulenb = + if !Flag_cocci.show_ctl_text or !Flag.show_trying or + !Flag_cocci.show_transinfo or !Flag_cocci.show_binding_in_out + then + begin + let name = i_to_s rulenb in + Common.pr_xxxxxxxxxxxxxxxxx (); + pr ("script rule " ^ name ^ " = "); + Common.pr_xxxxxxxxxxxxxxxxx () + end + +let show_or_not_ctl_text2 ctl ast rulenb = + if !Flag_cocci.show_ctl_text then begin + + adjust_pp_with_indent (fun () -> + Format.force_newline(); + Pretty_print_cocci.print_plus_flag := true; + Pretty_print_cocci.print_minus_flag := true; + Pretty_print_cocci.unparse ast; + ); + + pr "CTL = "; + let (ctl,_) = ctl in + adjust_pp_with_indent (fun () -> + Format.force_newline(); + Pretty_print_engine.pp_ctlcocci + !Flag_cocci.show_mcodekind_in_ctl !Flag_cocci.inline_let_ctl ctl; + ); + pr ""; + end +let show_or_not_ctl_text a b c = + Common.profile_code "show_xxx" (fun () -> show_or_not_ctl_text2 a b c) + + + +(* running information *) +let get_celem celem : string = + match celem with + Ast_c.Definition ({Ast_c.f_name = funcs;},_) -> funcs + | Ast_c.Declaration + (Ast_c.DeclList ([{Ast_c.v_namei = Some ((s, _),_);}, _], _)) -> s + | _ -> "" + +let show_or_not_celem2 prelude celem = + let (tag,trying) = + (match celem with + | Ast_c.Definition ({Ast_c.f_name = funcs;},_) -> + Flag.current_element := funcs; + (" function: ",funcs) + | Ast_c.Declaration + (Ast_c.DeclList ([{Ast_c.v_namei = Some ((s, _),_);}, _], _)) -> + Flag.current_element := s; + (" variable ",s); + | _ -> + Flag.current_element := "something_else"; + (" ","something else"); + ) in + if !Flag.show_trying then pr2 (prelude ^ tag ^ trying) + +let show_or_not_celem a b = + Common.profile_code "show_xxx" (fun () -> show_or_not_celem2 a b) + + +let show_or_not_trans_info2 trans_info = + if !Flag_cocci.show_transinfo then begin + if null trans_info then pr2 "transformation info is empty" + else begin + pr2 "transformation info returned:"; + let trans_info = + List.sort (function (i1,_,_) -> function (i2,_,_) -> compare i1 i2) + trans_info + in + indent_do (fun () -> + trans_info +> List.iter (fun (i, subst, re) -> + pr2 ("transform state: " ^ (Common.i_to_s i)); + indent_do (fun () -> + adjust_pp_with_indent_and_header "with rule_elem: " (fun () -> + Pretty_print_cocci.print_plus_flag := true; + Pretty_print_cocci.print_minus_flag := true; + Pretty_print_cocci.rule_elem "" re; + ); + adjust_pp_with_indent_and_header "with binding: " (fun () -> + Pretty_print_engine.pp_binding subst; + ); + ) + ); + ) + end + end +let show_or_not_trans_info a = + Common.profile_code "show_xxx" (fun () -> show_or_not_trans_info2 a) + + + +let show_or_not_binding2 s binding = + if !Flag_cocci.show_binding_in_out then begin + adjust_pp_with_indent_and_header ("binding " ^ s ^ " = ") (fun () -> + Pretty_print_engine.pp_binding binding + ) + end +let show_or_not_binding a b = + Common.profile_code "show_xxx" (fun () -> show_or_not_binding2 a b) + + + +(*****************************************************************************) +(* Some helper functions *) +(*****************************************************************************) + +let worth_trying cfiles tokens = + (* drop the following line for a list of list by rules. since we don't + allow multiple minirules, all the tokens within a rule should be in + a single CFG entity *) + let tokens = Common.union_all tokens in + if not !Flag_cocci.windows && not (null tokens) + then + (* could also modify the code in get_constants.ml *) + let tokens = tokens +> List.map (fun s -> + match () with + | _ when s =~ "^[A-Za-z_][A-Za-z_0-9]*$" -> + "\\b" ^ s ^ "\\b" + + | _ when s =~ "^[A-Za-z_]" -> + "\\b" ^ s + + | _ when s =~ ".*[A-Za-z_]$" -> + s ^ "\\b" + | _ -> s + + ) in + let com = sprintf "egrep -q '(%s)' %s" (join "|" tokens) (join " " cfiles) + in + (match Sys.command com with + | 0 (* success *) -> true + | _ (* failure *) -> + (if !Flag.show_misc + then Printf.printf "grep failed: %s\n" com); + false (* no match, so not worth trying *) + ) + else true + +let check_macro_in_sp_and_adjust tokens = + let tokens = Common.union_all tokens in + tokens +> List.iter (fun s -> + if Hashtbl.mem !Parsing_hacks._defs s + then begin + pr2 "warning: macro in semantic patch was in macro definitions"; + pr2 ("disabling macro expansion for " ^ s); + Hashtbl.remove !Parsing_hacks._defs s + end + ) + + +let contain_loop gopt = + match gopt with + | Some g -> + g#nodes#tolist +> List.exists (fun (xi, node) -> + Control_flow_c.extract_is_loop node + ) + | None -> true (* means nothing, if no g then will not model check *) + + + +let sp_contain_typed_metavar_z toplevel_list_list = + let bind x y = x or y in + let option_default = false in + let mcode _ _ = option_default in + let donothing r k e = k e in + + let expression r k e = + match Ast_cocci.unwrap e with + | Ast_cocci.MetaExpr (_,_,_,Some t,_,_) -> true + | Ast_cocci.MetaExpr (_,_,_,_,Ast_cocci.LocalID,_) -> true + | _ -> k e + in + + let combiner = + Visitor_ast.combiner bind option_default + mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode + mcode + donothing donothing donothing donothing + donothing expression donothing donothing donothing donothing donothing + donothing donothing donothing donothing donothing + in + toplevel_list_list +> + List.exists + (function (nm,_,rule) -> + (List.exists combiner.Visitor_ast.combiner_top_level rule)) + + +let sp_contain_typed_metavar rules = + sp_contain_typed_metavar_z + (List.map + (function x -> + match x with + Ast_cocci.CocciRule (a,b,c,d) -> (a,b,c) + | _ -> failwith "error in filter") + (List.filter + (function x -> + match x with Ast_cocci.CocciRule _ -> true | _ -> false) + rules)) + + + +(* finding among the #include the one that we need to parse + * because they may contain useful type definition or because + * we may have to modify them + * + * For the moment we base in part our heuristic on the name of the file, e.g. + * serio.c is related we think to #include + *) + +let (includes_to_parse: (Common.filename * Parse_c.program2) list -> 'a) = fun xs -> + if !Flag_cocci.no_includes + then [] + else + xs +> List.map (fun (file, cs) -> + let dir = Common.dirname file in + + cs +> Common.map_filter (fun (c,_info_item) -> + match c with + | Ast_c.CppTop (Ast_c.Include {Ast_c.i_include = ((x,ii)); + i_rel_pos = info_h_pos;}) -> + (match x with + | Ast_c.Local xs -> + let f = Filename.concat dir (Common.join "/" xs) in + (* for our tests, all the files are flat in the current dir *) + if not (Sys.file_exists f) && !Flag_cocci.relax_include_path + then + let attempt2 = Filename.concat dir (Common.last xs) in + if not (Sys.file_exists f) && !Flag_cocci.all_includes + then Some (Filename.concat !Flag_cocci.include_path + (Common.join "/" xs)) + else Some attempt2 + else Some f + + | Ast_c.NonLocal xs -> + if !Flag_cocci.all_includes || + Common.fileprefix (Common.last xs) = Common.fileprefix file + then + Some (Filename.concat !Flag_cocci.include_path + (Common.join "/" xs)) + else None + | Ast_c.Wierd _ -> None + ) + | _ -> None + ) + ) + +> List.concat + +> Common.uniq + +let rec interpret_dependencies local global = function + Ast_cocci.Dep s -> List.mem s local + | Ast_cocci.AntiDep s -> + (if !Flag_ctl.steps != None + then failwith "steps and ! dependency incompatible"); + not (List.mem s local) + | Ast_cocci.EverDep s -> List.mem s global + | Ast_cocci.NeverDep s -> + (if !Flag_ctl.steps != None + then failwith "steps and ! dependency incompatible"); + not (List.mem s global) + | Ast_cocci.AndDep(s1,s2) -> + (interpret_dependencies local global s1) && + (interpret_dependencies local global s2) + | Ast_cocci.OrDep(s1,s2) -> + (interpret_dependencies local global s1) or + (interpret_dependencies local global s2) + | Ast_cocci.NoDep -> true + +let rec print_dependencies str local global dep = + if !Flag_cocci.show_dependencies + then + begin + pr2 str; + let seen = ref [] in + let rec loop = function + Ast_cocci.Dep s | Ast_cocci.AntiDep s -> + if not (List.mem s !seen) + then + begin + if List.mem s local + then pr2 (s^" satisfied") + else pr2 (s^" not satisfied"); + seen := s :: !seen + end + | Ast_cocci.EverDep s | Ast_cocci.NeverDep s -> + if not (List.mem s !seen) + then + begin + if List.mem s global + then pr2 (s^" satisfied") + else pr2 (s^" not satisfied"); + seen := s :: !seen + end + | Ast_cocci.AndDep(s1,s2) -> + loop s1; + loop s2 + | Ast_cocci.OrDep(s1,s2) -> + loop s1; + loop s2 + | Ast_cocci.NoDep -> () in + loop dep + end + + + +(* --------------------------------------------------------------------- *) +(* #include relative position in the file *) +(* --------------------------------------------------------------------- *) + +(* compute the set of new prefixes + * on + * "a/b/x"; (* in fact it is now a list of string so ["a";"b";"x"] *) + * "a/b/c/x"; + * "a/x"; + * "b/x"; + * it would give for the first element + * ""; "a"; "a/b"; "a/b/x" + * for the second + * "a/b/c/x" + * + * update: if the include is inside a ifdef a put nothing. cf -test incl. + * this is because we dont want code added inside ifdef. + *) + +let compute_new_prefixes xs = + xs +> Common.map_withenv (fun already xs -> + let subdirs_prefixes = Common.inits xs in + let new_first = subdirs_prefixes +> List.filter (fun x -> + not (List.mem x already) + ) + in + new_first, + new_first @ already + ) [] + +> fst + + +(* does via side effect on the ref in the Include in Ast_c *) +let rec update_include_rel_pos cs = + let only_include = cs +> Common.map_filter (fun c -> + match c with + | Ast_c.CppTop (Ast_c.Include {Ast_c.i_include = ((x,_)); + i_rel_pos = aref; + i_is_in_ifdef = inifdef}) -> + (match x with + | Ast_c.Wierd _ -> None + | _ -> + if inifdef + then None + else Some (x, aref) + ) + | _ -> None + ) + in + let (locals, nonlocals) = + only_include +> Common.partition_either (fun (c, aref) -> + match c with + | Ast_c.Local x -> Left (x, aref) + | Ast_c.NonLocal x -> Right (x, aref) + | Ast_c.Wierd x -> raise Impossible + ) in + + update_rel_pos_bis locals; + update_rel_pos_bis nonlocals; + cs +and update_rel_pos_bis xs = + let xs' = List.map fst xs in + let the_first = compute_new_prefixes xs' in + let the_last = List.rev (compute_new_prefixes (List.rev xs')) in + let merged = Common.zip xs (Common.zip the_first the_last) in + merged +> List.iter (fun ((x, aref), (the_first, the_last)) -> + aref := Some + { + Ast_c.first_of = the_first; + Ast_c.last_of = the_last; + } + ) + + + + + + +(*****************************************************************************) +(* All the information needed around the C elements and Cocci rules *) +(*****************************************************************************) + +type toplevel_c_info = { + ast_c: Ast_c.toplevel; (* contain refs so can be modified *) + tokens_c: Parser_c.token list; + fullstring: string; + + flow: Control_flow_c.cflow option; (* it's the "fixed" flow *) + contain_loop: bool; + + env_typing_before: TAC.environment; + env_typing_after: TAC.environment; + + was_modified: bool ref; + + (* id: int *) +} + +type toplevel_cocci_info_script_rule = { + scr_ast_rule: string * (string * (string * string)) list * string; + language: string; + scr_dependencies: Ast_cocci.dependency; + scr_ruleid: int; + script_code: string; +} + +type toplevel_cocci_info_cocci_rule = { + ctl: Lib_engine.ctlcocci * (CCI.pred list list); + ast_rule: Ast_cocci.rule; + isexp: bool; (* true if + code is an exp, only for Flag.make_hrule *) + + rulename: string; + dependencies: Ast_cocci.dependency; + (* There are also some hardcoded rule names in parse_cocci.ml: + * let reserved_names = ["all";"optional_storage";"optional_qualifier"] + *) + dropped_isos: string list; + free_vars: Ast_cocci.meta_name list; + negated_pos_vars: Ast_cocci.meta_name list; + used_after: Ast_cocci.meta_name list; + positions: Ast_cocci.meta_name list; + + ruleid: int; + + was_matched: bool ref; +} + +type toplevel_cocci_info = + ScriptRuleCocciInfo of toplevel_cocci_info_script_rule + | CocciRuleCocciInfo of toplevel_cocci_info_cocci_rule + +type kind_file = Header | Source +type file_info = { + fname : string; + full_fname : string; + was_modified_once: bool ref; + asts: toplevel_c_info list; + fpath : string; + fkind : kind_file; +} + +let g_contain_typedmetavar = ref false + + +let last_env_toplevel_c_info xs = + (Common.last xs).env_typing_after + +let concat_headers_and_c (ccs: file_info list) + : (toplevel_c_info * string) list = + (List.concat (ccs +> List.map (fun x -> + x.asts +> List.map (fun x' -> + (x', x.fname))))) + +let for_unparser xs = + xs +> List.map (fun x -> + (x.ast_c, (x.fullstring, x.tokens_c)), Unparse_c.PPviastr + ) + +let gen_pdf_graph () = + (Ctl_engine.get_graph_files ()) +> List.iter (fun outfile -> + Printf.printf "Generation of %s%!" outfile; + let filename_stack = Ctl_engine.get_graph_comp_files outfile in + List.iter (fun filename -> + ignore (Unix.system ("dot " ^ filename ^ " -Tpdf -o " ^ filename ^ ".pdf;")) + ) filename_stack; + let (head,tail) = (List.hd filename_stack, List.tl filename_stack) in + ignore(Unix.system ("cp " ^ head ^ ".pdf " ^ outfile ^ ".pdf;")); + tail +> List.iter (fun filename -> + ignore(Unix.system ("mv " ^ outfile ^ ".pdf /tmp/tmp.pdf;")); + ignore(Unix.system ("pdftk " ^ filename ^ ".pdf /tmp/tmp.pdf cat output " ^ outfile ^ ".pdf")); + ); + ignore(Unix.system ("rm /tmp/tmp.pdf;")); + List.iter (fun filename -> + ignore (Unix.system ("rm " ^ filename ^ " " ^ filename ^ ".pdf;")) + ) filename_stack; + Printf.printf " - Done\n") + + +(* --------------------------------------------------------------------- *) +let prepare_cocci ctls free_var_lists negated_pos_lists + used_after_lists positions_list astcocci = + + let gathered = Common.index_list_1 + (zip (zip (zip (zip (zip ctls astcocci) free_var_lists) + negated_pos_lists) used_after_lists) positions_list) + in + gathered +> List.map + (fun ((((((ctl_toplevel_list,ast),free_var_list),negated_pos_list), + used_after_list), + positions_list),rulenb) -> + + let is_script_rule r = + match r with Ast_cocci.ScriptRule _ -> true | _ -> false in + + if not (List.length ctl_toplevel_list = 1) && not (is_script_rule ast) + then failwith "not handling multiple minirules"; + + match ast with + Ast_cocci.ScriptRule (lang,deps,mv,code) -> + let r = + { + scr_ast_rule = (lang, mv, code); + language = lang; + scr_dependencies = deps; + scr_ruleid = rulenb; + script_code = code; + } + in ScriptRuleCocciInfo r + | Ast_cocci.CocciRule + (rulename,(dependencies,dropped_isos,z),restast,isexp) -> + CocciRuleCocciInfo ( + { + ctl = List.hd ctl_toplevel_list; + ast_rule = ast; + isexp = List.hd isexp; + rulename = rulename; + dependencies = dependencies; + dropped_isos = dropped_isos; + free_vars = List.hd free_var_list; + negated_pos_vars = List.hd negated_pos_list; + used_after = List.hd used_after_list; + positions = List.hd positions_list; + ruleid = rulenb; + was_matched = ref false; + }) + ) + + +(* --------------------------------------------------------------------- *) + +let build_info_program cprogram env = + let (cs, parseinfos) = Common.unzip cprogram in + let (cs, envs) = + Common.unzip (TAC.annotate_program env !g_contain_typedmetavar cs) in + + zip (zip cs parseinfos) envs +> List.map (fun ((c, parseinfo), (enva,envb))-> + let (fullstr, tokens) = parseinfo in + + let flow = + ast_to_flow_with_error_messages c +> Common.map_option (fun flow -> + let flow = Ast_to_flow.annotate_loop_nodes flow in + + (* remove the fake nodes for julia *) + let fixed_flow = CCI.fix_flow_ctl flow in + + if !Flag_cocci.show_flow then print_flow fixed_flow; + if !Flag_cocci.show_before_fixed_flow then print_flow flow; + + fixed_flow + ) + in + + { + ast_c = c; (* contain refs so can be modified *) + tokens_c = tokens; + fullstring = fullstr; + + flow = flow; + + contain_loop = contain_loop flow; + + env_typing_before = enva; + env_typing_after = envb; + + was_modified = ref false; + } + ) + + + +(* Optimisation. Try not unparse/reparse the whole file when have modifs *) +let rebuild_info_program cs file isexp = + cs +> List.map (fun c -> + if !(c.was_modified) + then + (match !Flag.make_hrule with + Some dir -> + Unparse_hrule.pp_program (c.ast_c, (c.fullstring, c.tokens_c)) + dir file isexp; + [] + | None -> + let file = Common.new_temp_file "cocci_small_output" ".c" in + cfile_of_program + [(c.ast_c, (c.fullstring, c.tokens_c)), Unparse_c.PPnormal] + file; + + (* Common.command2 ("cat " ^ file); *) + let cprogram = cprogram_of_file file in + let xs = build_info_program cprogram c.env_typing_before in + + (* TODO: assert env has not changed, + * if yes then must also reparse what follows even if not modified. + * Do that only if contain_typedmetavar of course, so good opti. + *) + (* Common.list_init xs *) (* get rid of the FinalDef *) + xs) + else [c] + ) +> List.concat + + +let rebuild_info_c_and_headers ccs isexp = + ccs +> List.iter (fun c_or_h -> + if c_or_h.asts +> List.exists (fun c -> !(c.was_modified)) + then c_or_h.was_modified_once := true; + ); + ccs +> List.map (fun c_or_h -> + { c_or_h with + asts = rebuild_info_program c_or_h.asts c_or_h.full_fname isexp } + ) + + + + + + + +let prepare_c files : file_info list = + let cprograms = List.map cprogram_of_file_cached files in + let includes = includes_to_parse (zip files cprograms) in + + (* todo?: may not be good to first have all the headers and then all the c *) + let all = + (includes +> List.map (fun hpath -> Right hpath)) + ++ + ((zip files cprograms) +> List.map (fun (file, asts) -> Left (file, asts))) + in + + let env = ref TAC.initial_env in + + let ccs = all +> Common.map_filter (fun x -> + match x with + | Right hpath -> + if not (Common.lfile_exists hpath) + then begin + pr2 ("TYPE: header " ^ hpath ^ " not found"); + None + end + else + let h_cs = cprogram_of_file_cached hpath in + let info_h_cs = build_info_program h_cs !env in + env := + if null info_h_cs + then !env + else last_env_toplevel_c_info info_h_cs + ; + Some { + fname = Common.basename hpath; + full_fname = hpath; + asts = info_h_cs; + was_modified_once = ref false; + fpath = hpath; + fkind = Header; + } + | Left (file, cprogram) -> + (* todo?: don't update env ? *) + let cs = build_info_program cprogram !env in + (* we do that only for the c, not for the h *) + ignore(update_include_rel_pos (cs +> List.map (fun x -> x.ast_c))); + Some { + fname = Common.basename file; + full_fname = file; + asts = cs; + was_modified_once = ref false; + fpath = file; + fkind = Source; + } + ) + in + ccs + + +(*****************************************************************************) +(* Processing the ctls and toplevel C elements *) +(*****************************************************************************) + +(* The main algorithm =~ + * The algorithm is roughly: + * for_all ctl rules in SP + * for_all minirule in rule (no more) + * for_all binding (computed during previous phase) + * for_all C elements + * match control flow of function vs minirule + * with the binding and update the set of possible + * bindings, and returned the possibly modified function. + * pretty print modified C elements and reparse it. + * + * + * On ne prends que les newbinding ou returned_any_state est vrai. + * Si ca ne donne rien, on prends ce qu'il y avait au depart. + * Mais au nouveau depart de quoi ? + * - si ca donne rien apres avoir traité toutes les fonctions avec ce binding ? + * - ou alors si ca donne rien, apres avoir traité toutes les fonctions + * avec tous les bindings du round d'avant ? + * + * Julia pense qu'il faut prendre la premiere solution. + * Example: on a deux environnements candidats, E1 et E2 apres avoir traité + * la regle ctl 1. On arrive sur la regle ctl 2. + * E1 ne donne rien pour la regle 2, on garde quand meme E1 pour la regle 3. + * E2 donne un match a un endroit et rend E2' alors on utilise ca pour + * la regle 3. + * + * I have not to look at used_after_list to decide to restart from + * scratch. I just need to look if the binding list is empty. + * Indeed, let's suppose that a SP have 3 regions/rules. If we + * don't find a match for the first region, then if this first + * region does not bind metavariable used after, that is if + * used_after_list is empty, then mysat(), even if does not find a + * match, will return a Left, with an empty transformation_info, + * and so current_binding will grow. On the contrary if the first + * region must bind some metavariables used after, and that we + * dont find any such region, then mysat() will returns lots of + * Right, and current_binding will not grow, and so we will have + * an empty list of binding, and we will catch such a case. + * + * opti: julia says that because the binding is + * determined by the used_after_list, the items in the list + * are kind of sorted, so could optimise the insert_set operations. + *) + + +(* r(ule), c(element in C code), e(nvironment) *) + +let rec apply_python_rule r cache newes e rules_that_have_matched + rules_that_have_ever_matched = + show_or_not_scr_rule_name r.scr_ruleid; + if not(interpret_dependencies rules_that_have_matched + !rules_that_have_ever_matched r.scr_dependencies) + then + begin + print_dependencies "dependencies for script not satisfied:" + rules_that_have_matched + !rules_that_have_ever_matched r.scr_dependencies; + show_or_not_binding "in environment" e; + (cache, (e, rules_that_have_matched)::newes) + end + else + begin + let (_, mv, _) = r.scr_ast_rule in + if List.for_all (Pycocci.contains_binding e) mv + then + begin + let relevant_bindings = + List.filter + (function ((re,rm),_) -> + List.exists (function (_,(r,m)) -> r = re && m = rm) mv) + e in + let new_cache = + if List.mem relevant_bindings cache + then cache + else + begin + print_dependencies "dependencies for script satisfied:" + rules_that_have_matched + !rules_that_have_ever_matched r.scr_dependencies; + show_or_not_binding "in" e; + Pycocci.build_classes (List.map (function (x,y) -> x) e); + Pycocci.construct_variables mv e; + let _ = Pycocci.pyrun_simplestring + ("import coccinelle\nfrom coccinelle "^ + "import *\ncocci = Cocci()\n" ^ + r.script_code) in + relevant_bindings :: cache + end in + if !Pycocci.inc_match + then (new_cache, merge_env [(e, rules_that_have_matched)] newes) + else (new_cache, newes) + end + else (cache, merge_env [(e, rules_that_have_matched)] newes) + end + +and apply_cocci_rule r rules_that_have_ever_matched es (ccs:file_info list ref) = + Common.profile_code r.rulename (fun () -> + show_or_not_rule_name r.ast_rule r.ruleid; + show_or_not_ctl_text r.ctl r.ast_rule r.ruleid; + + let reorganized_env = + reassociate_positions r.free_vars r.negated_pos_vars !es in + + (* looping over the environments *) + let (_,newes (* envs for next round/rule *)) = + List.fold_left + (function (cache,newes) -> + function ((e,rules_that_have_matched),relevant_bindings) -> + if not(interpret_dependencies rules_that_have_matched + !rules_that_have_ever_matched r.dependencies) + then + begin + print_dependencies + ("dependencies for rule "^r.rulename^" not satisfied:") + rules_that_have_matched + !rules_that_have_ever_matched r.dependencies; + show_or_not_binding "in environment" e; + (cache, + merge_env + [(e +> List.filter (fun (s,v) -> List.mem s r.used_after), + rules_that_have_matched)] + newes) + end + else + let new_bindings = + try List.assoc relevant_bindings cache + with + Not_found -> + print_dependencies + ("dependencies for rule "^r.rulename^" satisfied:") + rules_that_have_matched + !rules_that_have_ever_matched r.dependencies; + show_or_not_binding "in" e; + show_or_not_binding "relevant in" relevant_bindings; + + let children_e = ref [] in + + (* looping over the functions and toplevel elements in + .c and .h *) + concat_headers_and_c !ccs +> List.iter (fun (c,f) -> + if c.flow <> None + then + (* does also some side effects on c and r *) + let processed = + process_a_ctl_a_env_a_toplevel r relevant_bindings + c f in + match processed with + | None -> () + | Some newbindings -> + newbindings +> List.iter (fun newbinding -> + children_e := + Common.insert_set newbinding !children_e) + ); (* end iter cs *) + + !children_e in + let old_bindings_to_keep = + Common.nub + (e +> List.filter (fun (s,v) -> List.mem s r.used_after)) in + let new_e = + if null new_bindings + then + begin + (*use the old bindings, specialized to the used_after_list*) + if !Flag_ctl.partial_match + then + printf + "Empty list of bindings, I will restart from old env"; + [(old_bindings_to_keep,rules_that_have_matched)] + end + else + (* combine the new bindings with the old ones, and + specialize to the used_after_list *) + let old_variables = List.map fst old_bindings_to_keep in + (* have to explicitly discard the inherited variables + because we want the inherited value of the positions + variables not the extended one created by + reassociate_positions. want to reassociate freshly + according to the free variables of each rule. *) + let new_bindings_to_add = + Common.nub + (new_bindings +> + List.map + (List.filter + (fun (s,v) -> + List.mem s r.used_after && + not (List.mem s old_variables)))) in + List.map + (function new_binding_to_add -> + (List.sort compare + (Common.union_set + old_bindings_to_keep new_binding_to_add), + r.rulename::rules_that_have_matched)) + new_bindings_to_add in + ((relevant_bindings,new_bindings)::cache, + merge_env new_e newes)) + ([],[]) reorganized_env in (* end iter es *) + if !(r.was_matched) + then Common.push2 r.rulename rules_that_have_ever_matched; + + es := newes; + + (* apply the tagged modifs and reparse *) + if not !Flag.sgrep_mode2 + then ccs := rebuild_info_c_and_headers !ccs r.isexp + ) + +and merge_env new_e old_e = + List.fold_left + (function old_e -> + function (e,rules) as elem -> + let (same,diff) = List.partition (function (e1,_) -> e = e1) old_e in + match same with + [] -> elem :: old_e + | [(_,old_rules)] -> (e,Common.union_set rules old_rules) :: diff + | _ -> failwith "duplicate environment entries") + old_e new_e + +and bigloop2 rs (ccs: file_info list) = + let es = ref [(Ast_c.emptyMetavarsBinding,[])] in + let ccs = ref ccs in + let rules_that_have_ever_matched = ref [] in + + (* looping over the rules *) + rs +> List.iter (fun r -> + match r with + ScriptRuleCocciInfo r -> + if !Flag_cocci.show_ctl_text then begin + Common.pr_xxxxxxxxxxxxxxxxx (); + pr ("script: " ^ r.language); + Common.pr_xxxxxxxxxxxxxxxxx (); + + adjust_pp_with_indent (fun () -> + Format.force_newline(); + let (l,mv,code) = r.scr_ast_rule in + let deps = r.scr_dependencies in + Pretty_print_cocci.unparse + (Ast_cocci.ScriptRule (l,deps,mv,code))); + end; + + if !Flag.show_misc then print_endline "RESULT ="; + + let (_, newes) = + List.fold_left + (function (cache, newes) -> + function (e, rules_that_have_matched) -> + match r.language with + "python" -> + apply_python_rule r cache newes e rules_that_have_matched + rules_that_have_ever_matched + | "test" -> + concat_headers_and_c !ccs +> List.iter (fun (c,_) -> + if c.flow <> None + then + Printf.printf "Flow: %s\r\nFlow!\r\n%!" c.fullstring); + (cache, newes) + | _ -> + Printf.printf "Unknown language: %s\n" r.language; + (cache, newes) + ) + ([],[]) !es in + + es := newes; + | CocciRuleCocciInfo r -> + apply_cocci_rule r rules_that_have_ever_matched es ccs); + + if !Flag.sgrep_mode2 + then begin + (* sgrep can lead to code that is not parsable, but we must + * still call rebuild_info_c_and_headers to pretty print the + * action (MINUS), so that later the diff will show what was + * matched by sgrep. But we don't want the parsing error message + * hence the following flag setting. So this code propably + * will generate a NotParsedCorrectly for the matched parts + * and the very final pretty print and diff will work + *) + Flag_parsing_c.verbose_parsing := false; + ccs := rebuild_info_c_and_headers !ccs false + end; + !ccs (* return final C asts *) + +and reassociate_positions free_vars negated_pos_vars envs = + (* issues: isolate the bindings that are relevant to a given rule. + separate out the position variables + associate all of the position variables for a given set of relevant + normal variable bindings with each set of relevant normal variable + bindings. Goal: if eg if@p (E) matches in two places, then both inherited + occurrences of E should see both bindings of p, not just its own. + Otherwise, a position constraint for something that matches in two + places will never be useful, because the position can always be + different from the other one. *) + let relevant = + List.map + (function (e,_) -> + List.filter (function (x,_) -> List.mem x free_vars) e) + envs in + let splitted_relevant = + (* separate the relevant variables into the non-position ones and the + position ones *) + List.map + (function r -> + List.fold_left + (function (non_pos,pos) -> + function (v,_) as x -> + if List.mem v negated_pos_vars + then (non_pos,x::pos) + else (x::non_pos,pos)) + ([],[]) r) + relevant in + let splitted_relevant = + List.map + (function (non_pos,pos) -> + (List.sort compare non_pos,List.sort compare pos)) + splitted_relevant in + let non_poss = + List.fold_left + (function non_pos -> + function (np,_) -> + if List.mem np non_pos then non_pos else np::non_pos) + [] splitted_relevant in + let extended_relevant = + (* extend the position variables with the values found at other identical + variable bindings *) + List.map + (function non_pos -> + let others = + List.filter + (function (other_non_pos,other_pos) -> + (* do we want equal? or just somehow compatible? eg non_pos + binds only E, but other_non_pos binds both E and E1 *) + non_pos = other_non_pos) + splitted_relevant in + (non_pos, + List.sort compare + (non_pos @ + (combine_pos negated_pos_vars + (List.map (function (_,x) -> x) others))))) + non_poss in + List.combine envs + (List.map (function (non_pos,_) -> List.assoc non_pos extended_relevant) + splitted_relevant) + +and combine_pos negated_pos_vars others = + List.map + (function posvar -> + (posvar, + Ast_c.MetaPosValList + (List.sort compare + (List.fold_left + (function positions -> + function other_list -> + try + match List.assoc posvar other_list with + Ast_c.MetaPosValList l1 -> + Common.union_set l1 positions + | _ -> failwith "bad value for a position variable" + with Not_found -> positions) + [] others)))) + negated_pos_vars + +and bigloop a b = + Common.profile_code "bigloop" (fun () -> bigloop2 a b) + + + + + +(* does side effects on C ast and on Cocci info rule *) +and process_a_ctl_a_env_a_toplevel2 r e c f = + indent_do (fun () -> + show_or_not_celem "trying" c.ast_c; + Flag.currentfile := Some (f ^ ":" ^get_celem c.ast_c); + let (trans_info, returned_any_states, inherited_bindings, newbindings) = + Common.save_excursion Flag_ctl.loop_in_src_code (fun () -> + Flag_ctl.loop_in_src_code := !Flag_ctl.loop_in_src_code||c.contain_loop; + + (***************************************) + (* !Main point! The call to the engine *) + (***************************************) + let model_ctl = CCI.model_for_ctl r.dropped_isos (Common.some c.flow) e + in CCI.mysat model_ctl r.ctl (r.used_after, e) + ) + in + if not returned_any_states + then None + else begin + show_or_not_celem "found match in" c.ast_c; + show_or_not_trans_info trans_info; + List.iter (show_or_not_binding "out") newbindings; + + r.was_matched := true; + + if not (null trans_info) + then begin + c.was_modified := true; + try + (* les "more than one var in a decl" et "already tagged token" + * font crasher coccinelle. Si on a 5 fichiers, donc on a 5 + * failed. Le try limite le scope des crashes pendant la + * trasformation au fichier concerne. *) + + (* modify ast via side effect *) + ignore(Transformation_c.transform r.rulename r.dropped_isos + inherited_bindings trans_info (Common.some c.flow)); + with Timeout -> raise Timeout | UnixExit i -> raise (UnixExit i) + end; + + Some (List.map (function x -> x@inherited_bindings) newbindings) + end + ) + +and process_a_ctl_a_env_a_toplevel a b c f= + Common.profile_code "process_a_ctl_a_env_a_toplevel" + (fun () -> process_a_ctl_a_env_a_toplevel2 a b c f) + + + +(*****************************************************************************) +(* The main function *) +(*****************************************************************************) + +let full_engine2 (coccifile, isofile) cfiles = + + show_or_not_cfiles cfiles; + show_or_not_cocci coccifile isofile; + Pycocci.set_coccifile coccifile; + + let isofile = + if not (Common.lfile_exists isofile) + then begin + pr2 ("warning: Can't find default iso file: " ^ isofile); + None + end + else Some isofile + in + + (* useful opti when use -dir *) + let (astcocci,free_var_lists,negated_pos_lists,used_after_lists, + positions_lists,toks,_) = + sp_of_file coccifile isofile + in + let ctls = + Common.memoized _hctl (coccifile, isofile) (fun () -> + ctls_of_ast astcocci used_after_lists positions_lists) + in + + let contain_typedmetavar = sp_contain_typed_metavar astcocci in + + (* optimisation allowing to launch coccinelle on all the drivers *) + if !Flag_cocci.worth_trying_opt && not (worth_trying cfiles toks) + then begin + pr2 ("not worth trying:" ^ Common.join " " cfiles); + cfiles +> List.map (fun s -> s, None) + end + else begin + + if !Flag.show_misc then Common.pr_xxxxxxxxxxxxxxxxx(); + if !Flag.show_misc then pr "let's go"; + if !Flag.show_misc then Common.pr_xxxxxxxxxxxxxxxxx(); + + g_contain_typedmetavar := contain_typedmetavar; + + check_macro_in_sp_and_adjust toks; + + let cocci_infos = + prepare_cocci ctls free_var_lists negated_pos_lists + used_after_lists positions_lists astcocci in + let c_infos = prepare_c cfiles in + + show_or_not_ctl_tex astcocci ctls; + + (* ! the big loop ! *) + let c_infos' = bigloop cocci_infos c_infos in + + if !Flag.show_misc then Common.pr_xxxxxxxxxxxxxxxxx (); + if !Flag.show_misc then pr "Finished"; + if !Flag_ctl.graphical_trace then gen_pdf_graph (); + if !Flag.show_misc then Common.pr_xxxxxxxxxxxxxxxxx(); + + c_infos' +> List.map (fun c_or_h -> + if !(c_or_h.was_modified_once) + then begin + let outfile = Common.new_temp_file "cocci-output" ("-" ^ c_or_h.fname) + in + + if c_or_h.fkind = Header + then pr2 ("a header file was modified: " ^ c_or_h.fname); + + (* and now unparse everything *) + cfile_of_program (for_unparser c_or_h.asts) outfile; + + let show_only_minus = !Flag.sgrep_mode2 in + show_or_not_diff c_or_h.fpath outfile show_only_minus; + + (c_or_h.fpath, + if !Flag.sgrep_mode2 then None else Some outfile + ) + end + else + (c_or_h.fpath, None) + ); + end + +let full_engine a b = + Common.profile_code "full_engine" (fun () -> full_engine2 a b) + + +(*****************************************************************************) +(* check duplicate from result of full_engine *) +(*****************************************************************************) + +let check_duplicate_modif2 xs = + (* opti: let groups = Common.groupBy (fun (a,resa) (b,resb) -> a =$= b) xs *) + pr2 ("Check duplication for " ^ i_to_s (List.length xs) ^ " files"); + let groups = Common.group_assoc_bykey_eff xs in + groups +> Common.map_filter (fun (file, xs) -> + match xs with + | [] -> raise Impossible + | [res] -> Some (file, res) + | res::xs -> + match res with + | None -> + if not (List.for_all (fun res2 -> res2 = None) xs) + then begin + pr2 ("different modification result for " ^ file); + None + end + else Some (file, None) + | Some res -> + if not(List.for_all (fun res2 -> + match res2 with + | None -> false + | Some res2 -> + let diff = Common.cmd_to_list ("diff -u -b -B "^res^" "^res2) + in + null diff + ) xs) then begin + pr2 ("different modification result for " ^ file); + None + end + else Some (file, Some res) + + + ) +let check_duplicate_modif a = + Common.profile_code "check_duplicate" (fun () -> check_duplicate_modif2 a) + diff --git a/.cvsignore b/.cvsignore index da56228..9adde69 100644 --- a/.cvsignore +++ b/.cvsignore @@ -1,3 +1,5 @@ .depend +test.ml Makefile.config spatch +spatch.opt diff --git a/.depend b/.depend index 30da4d6..27f9886 100644 --- a/.depend +++ b/.depend @@ -4,11 +4,12 @@ cocci.cmo: parsing_cocci/visitor_ast.cmi parsing_c/unparse_hrule.cmi \ parsing_c/unparse_c.cmi parsing_c/type_annoter_c.cmi \ engine/transformation_c.cmi python/pycocci.cmo \ engine/pretty_print_engine.cmi parsing_cocci/pretty_print_cocci.cmi \ - popl09/popl.cmi parsing_c/parsing_hacks.cmi parsing_cocci/parse_cocci.cmi \ - parsing_c/parse_c.cmi commons/ograph_extended.cmi engine/lib_engine.cmo \ + popl09/popl.cmi parsing_c/parsing_hacks.cmi parsing_c/parser_c.cmi \ + parsing_cocci/parse_cocci.cmi parsing_c/parse_c.cmi \ + commons/ograph_extended.cmi engine/lib_engine.cmo \ parsing_c/flag_parsing_c.cmo ctl/flag_ctl.cmo flag_cocci.cmo \ globals/flag.cmo engine/ctltotex.cmi engine/ctlcocci_integration.cmi \ - parsing_c/cpp_ast_c.cmi parsing_c/control_flow_c.cmi \ + ctl/ctl_engine.cmi parsing_c/cpp_ast_c.cmi parsing_c/control_flow_c.cmi \ parsing_c/compare_c.cmi commons/common.cmi engine/asttomember.cmi \ engine/asttoctl2.cmi parsing_c/ast_to_flow.cmi \ parsing_cocci/ast_cocci.cmi parsing_c/ast_c.cmo cocci.cmi @@ -16,11 +17,12 @@ cocci.cmx: parsing_cocci/visitor_ast.cmx parsing_c/unparse_hrule.cmx \ parsing_c/unparse_c.cmx parsing_c/type_annoter_c.cmx \ engine/transformation_c.cmx python/pycocci.cmx \ engine/pretty_print_engine.cmx parsing_cocci/pretty_print_cocci.cmx \ - popl09/popl.cmx parsing_c/parsing_hacks.cmx parsing_cocci/parse_cocci.cmx \ - parsing_c/parse_c.cmx commons/ograph_extended.cmx engine/lib_engine.cmx \ + popl09/popl.cmx parsing_c/parsing_hacks.cmx parsing_c/parser_c.cmx \ + parsing_cocci/parse_cocci.cmx parsing_c/parse_c.cmx \ + commons/ograph_extended.cmx engine/lib_engine.cmx \ parsing_c/flag_parsing_c.cmx ctl/flag_ctl.cmx flag_cocci.cmx \ globals/flag.cmx engine/ctltotex.cmx engine/ctlcocci_integration.cmx \ - parsing_c/cpp_ast_c.cmx parsing_c/control_flow_c.cmx \ + ctl/ctl_engine.cmx parsing_c/cpp_ast_c.cmx parsing_c/control_flow_c.cmx \ parsing_c/compare_c.cmx commons/common.cmx engine/asttomember.cmx \ engine/asttoctl2.cmx parsing_c/ast_to_flow.cmx \ parsing_cocci/ast_cocci.cmx parsing_c/ast_c.cmx cocci.cmi diff --git a/changes.txt b/changes.txt index c1493ab..9c5ea11 100644 --- a/changes.txt +++ b/changes.txt @@ -1,5 +1,26 @@ -*- org -*- +* 0.1.3 + +** Features: +- help in building the configuration macro file. The -parse_c action + now returns the 10 most frequent parsing errors. This give useful + hints to extend standard.h. + +** Bugfix: +- positions no longer allowed on \(, \|, and \) +- improved propagation of negation for isos in the presence of parens +- convert Todos in flow graph construction to recoverable errors +- fixed bug in treatment of when != true and when != false, to allow more + than one of them per ... +- improve parsing of typedef of function pointer. +- improve typing. +- parsing and typing support for old style C function declaration. +- consider position variables as modifications when optimizing the + translation into CTL of function definitions + +** Internals: + * 0.1.2 ** Bugfix: diff --git a/cocci.ml b/cocci.ml index 6ab9293..33f9509 100644 --- a/cocci.ml +++ b/cocci.ml @@ -780,7 +780,7 @@ let prepare_cocci ctls free_var_lists negated_pos_lists let build_info_program cprogram env = let (cs, parseinfos) = Common.unzip cprogram in let (cs, envs) = - Common.unzip (TAC.annotate_program env !g_contain_typedmetavar cs) in + Common.unzip (TAC.annotate_program env (*!g_contain_typedmetavar*) cs) in zip (zip cs parseinfos) envs +> List.map (fun ((c, parseinfo), (enva,envb))-> let (fullstr, tokens) = parseinfo in @@ -874,7 +874,7 @@ let prepare_c files : file_info list = ((zip files cprograms) +> List.map (fun (file, asts) -> Left (file, asts))) in - let env = ref TAC.initial_env in + let env = ref !TAC.initial_env in let ccs = all +> Common.map_filter (fun x -> match x with diff --git a/commitmsg b/commitmsg dissimilarity index 94% index 62edc40..30c7367 100644 --- a/commitmsg +++ b/commitmsg @@ -1,8 +1,18 @@ -Release coccinelle-0.1.2 - -** Bugfix: - - better handling of ifdef on statements in control flow graph. - - transform files even if they do not end in .c (thanks to Vegard Nossum) - -** Internals: - - merge code of yacfe +Release coccinelle-0.1.3 + +** Features: + - help in building the configuration macro file. The -parse_c action + now returns the 10 most frequent parsing errors. This give useful + hints to extend standard.h. + +** Bugfix: + - positions no longer allowed on \(, \|, and \) + - improved propagation of negation for isos in the presence of parens + - convert Todos in flow graph construction to recoverable errors + - fixed bug in treatment of when != true and when != false, to allow more + than one of them per ... + - improve parsing of typedef of function pointer. + - improve typing. + - parsing and typing support for old style C function declaration. + - consider position variables as modifications when optimizing the + translation into CTL of function definitions diff --git a/commons/.depend b/commons/.depend index eae66ad..97cf7ac 100644 --- a/commons/.depend +++ b/commons/.depend @@ -1,11 +1,7 @@ oarray.cmi: osequence.cmi ocollection.cmi oassoc.cmi: ocollection.cmi -oassoc_buffer.cmi: ocollection.cmi oassoc.cmi -oassocbdb.cmi: ocollection.cmi oassoc.cmi -oassocdbm.cmi: ocollection.cmi oassoc.cmi common.cmi ocollection.cmi: objet.cmi ograph.cmi: oset.cmi -ograph2way.cmi: oset.cmi ograph.cmi ograph_extended.cmi: oset.cmi oassoc.cmi common.cmi osequence.cmi: oassoc.cmi oset.cmi: seti.cmo ocamlextra/setb.cmi ocamlextra/setPt.cmo ocollection.cmi @@ -21,56 +17,34 @@ interfaces.cmo: common.cmi interfaces.cmx: common.cmx oarray.cmo: osequence.cmi common.cmi oarray.cmi oarray.cmx: osequence.cmx common.cmx oarray.cmi -oassoc.cmo: ocollection.cmi oassoc.cmi -oassoc.cmx: ocollection.cmx oassoc.cmi -oassoc_buffer.cmo: ocamlextra/setb.cmi osetb.cmo oassocb.cmo oassoc.cmi \ - common.cmi oassoc_buffer.cmi -oassoc_buffer.cmx: ocamlextra/setb.cmx osetb.cmx oassocb.cmx oassoc.cmx \ - common.cmx oassoc_buffer.cmi -oassocb.cmo: oassoc.cmi ocamlextra/mapb.cmo common.cmi -oassocb.cmx: oassoc.cmx ocamlextra/mapb.cmx common.cmx -oassocbdb.cmo: oassoc.cmi ocamlextra/dumper.cmi common.cmi oassocbdb.cmi -oassocbdb.cmx: oassoc.cmx ocamlextra/dumper.cmx common.cmx oassocbdb.cmi -oassocdbm.cmo: oassoc.cmi common.cmi oassocdbm.cmi -oassocdbm.cmx: oassoc.cmx common.cmx oassocdbm.cmi -oassoch.cmo: oassoc.cmi ocamlextra/dumper.cmi common.cmi -oassoch.cmx: oassoc.cmx ocamlextra/dumper.cmx common.cmx -oassocid.cmo: oassoc.cmi common.cmi -oassocid.cmx: oassoc.cmx common.cmx +oassoc.cmo: ocollection.cmi common.cmi oassoc.cmi +oassoc.cmx: ocollection.cmx common.cmx oassoc.cmi objet.cmo: common.cmi objet.cmi objet.cmx: common.cmx objet.cmi ocollection.cmo: objet.cmi common.cmi ocollection.cmi ocollection.cmx: objet.cmx common.cmx ocollection.cmi -ofullcommon.cmo: oseti.cmo osetb.cmo oset.cmi ograph2way.cmi ograph.cmi \ - oassoch.cmo oassocb.cmo oassoc_buffer.cmi oassoc.cmi oarray.cmi \ - common.cmi -ofullcommon.cmx: oseti.cmx osetb.cmx oset.cmx ograph2way.cmx ograph.cmx \ - oassoch.cmx oassocb.cmx oassoc_buffer.cmx oassoc.cmx oarray.cmx \ - common.cmx +ofullcommon.cmo: ocollection/oseti.cmo ocollection/osetb.cmo oset.cmi \ + ocollection/ograph2way.cmi ograph.cmi ocollection/oassoch.cmo \ + ocollection/oassocb.cmo ocollection/oassoc_buffer.cmi oassoc.cmi \ + oarray.cmi common.cmi +ofullcommon.cmx: ocollection/oseti.cmx ocollection/osetb.cmx oset.cmx \ + ocollection/ograph2way.cmx ograph.cmx ocollection/oassoch.cmx \ + ocollection/oassocb.cmx ocollection/oassoc_buffer.cmx oassoc.cmx \ + oarray.cmx common.cmx ograph.cmo: oset.cmi common.cmi ograph.cmi ograph.cmx: oset.cmx common.cmx ograph.cmi -ograph2way.cmo: ocamlextra/setb.cmi osetb.cmo oset.cmi ograph.cmi \ - ocollection.cmi common.cmi ograph2way.cmi -ograph2way.cmx: ocamlextra/setb.cmx osetb.cmx oset.cmx ograph.cmx \ - ocollection.cmx common.cmx ograph2way.cmi -ograph_extended.cmo: ocamlextra/setb.cmi osetb.cmo oset.cmi ocollection.cmi \ - oassocb.cmo oassoc.cmi common.cmi ograph_extended.cmi -ograph_extended.cmx: ocamlextra/setb.cmx osetb.cmx oset.cmx ocollection.cmx \ - oassocb.cmx oassoc.cmx common.cmx ograph_extended.cmi +ograph_extended.cmo: ocamlextra/setb.cmi ocollection/osetb.cmo oset.cmi \ + ocollection.cmi ocollection/oassocb.cmo oassoc.cmi common.cmi \ + ograph_extended.cmi +ograph_extended.cmx: ocamlextra/setb.cmx ocollection/osetb.cmx oset.cmx \ + ocollection.cmx ocollection/oassocb.cmx oassoc.cmx common.cmx \ + ograph_extended.cmi osequence.cmo: oassoc.cmi osequence.cmi osequence.cmx: oassoc.cmx osequence.cmi oset.cmo: seti.cmo ocamlextra/setb.cmi ocamlextra/setPt.cmo ocollection.cmi \ common.cmi oset.cmi oset.cmx: seti.cmx ocamlextra/setb.cmx ocamlextra/setPt.cmx ocollection.cmx \ common.cmx oset.cmi -osetb.cmo: ocamlextra/setb.cmi oset.cmi ocollection.cmi -osetb.cmx: ocamlextra/setb.cmx oset.cmx ocollection.cmx -oseth.cmo: oset.cmi common.cmi -oseth.cmx: oset.cmx common.cmx -oseti.cmo: seti.cmo oset.cmi ocollection.cmi -oseti.cmx: seti.cmx oset.cmx ocollection.cmx -osetpt.cmo: ocamlextra/setPt.cmo oset.cmi ocollection.cmi -osetpt.cmx: ocamlextra/setPt.cmx oset.cmx ocollection.cmx parser_combinators.cmo: common.cmi parser_combinators.cmi parser_combinators.cmx: common.cmx parser_combinators.cmi seti.cmo: common.cmi @@ -79,16 +53,48 @@ ocamlextra/ANSITerminal.cmo: ocamlextra/ANSITerminal.cmi ocamlextra/ANSITerminal.cmx: ocamlextra/ANSITerminal.cmi ocamlextra/dumper.cmo: ocamlextra/dumper.cmi ocamlextra/dumper.cmx: ocamlextra/dumper.cmi -ocamlextra/dynArray.cmo: ocamlextra/enum.cmi ocamlextra/dynArray.cmi -ocamlextra/dynArray.cmx: ocamlextra/enum.cmx ocamlextra/dynArray.cmi +ocamlextra/dynArray.cmo: ocamlextra/dynArray.cmi +ocamlextra/dynArray.cmx: ocamlextra/dynArray.cmi ocamlextra/enum.cmo: ocamlextra/enum.cmi ocamlextra/enum.cmx: ocamlextra/enum.cmi ocamlextra/setb.cmo: ocamlextra/setb.cmi ocamlextra/setb.cmx: ocamlextra/setb.cmi ocamlextra/suffix_tree.cmo: ocamlextra/suffix_tree.cmi ocamlextra/suffix_tree.cmx: ocamlextra/suffix_tree.cmi -ocamlextra/suffix_tree_ext.cmo: ocamlextra/dynArray.cmi \ - ocamlextra/suffix_tree_ext.cmi -ocamlextra/suffix_tree_ext.cmx: ocamlextra/dynArray.cmx \ - ocamlextra/suffix_tree_ext.cmi -ocamlextra/dynArray.cmi: ocamlextra/enum.cmi +ocamlextra/suffix_tree_ext.cmo: ocamlextra/suffix_tree_ext.cmi +ocamlextra/suffix_tree_ext.cmx: ocamlextra/suffix_tree_ext.cmi +ocollection/oassoc_buffer.cmo: oassoc.cmi common.cmi \ + ocollection/oassoc_buffer.cmi +ocollection/oassoc_buffer.cmx: oassoc.cmx common.cmx \ + ocollection/oassoc_buffer.cmi +ocollection/oassocb.cmo: oassoc.cmi common.cmi +ocollection/oassocb.cmx: oassoc.cmx common.cmx +ocollection/oassocbdb.cmo: oassoc.cmi common.cmi ocollection/oassocbdb.cmi +ocollection/oassocbdb.cmx: oassoc.cmx common.cmx ocollection/oassocbdb.cmi +ocollection/oassocbdb_string.cmo: oassoc.cmi common.cmi \ + ocollection/oassocbdb_string.cmi +ocollection/oassocbdb_string.cmx: oassoc.cmx common.cmx \ + ocollection/oassocbdb_string.cmi +ocollection/oassocdbm.cmo: oassoc.cmi common.cmi ocollection/oassocdbm.cmi +ocollection/oassocdbm.cmx: oassoc.cmx common.cmx ocollection/oassocdbm.cmi +ocollection/oassoch.cmo: oassoc.cmi common.cmi +ocollection/oassoch.cmx: oassoc.cmx common.cmx +ocollection/oassocid.cmo: oassoc.cmi common.cmi +ocollection/oassocid.cmx: oassoc.cmx common.cmx +ocollection/ograph2way.cmo: oset.cmi ograph.cmi ocollection.cmi common.cmi \ + ocollection/ograph2way.cmi +ocollection/ograph2way.cmx: oset.cmx ograph.cmx ocollection.cmx common.cmx \ + ocollection/ograph2way.cmi +ocollection/osetb.cmo: oset.cmi ocollection.cmi +ocollection/osetb.cmx: oset.cmx ocollection.cmx +ocollection/oseth.cmo: oset.cmi common.cmi +ocollection/oseth.cmx: oset.cmx common.cmx +ocollection/oseti.cmo: seti.cmo oset.cmi ocollection.cmi +ocollection/oseti.cmx: seti.cmx oset.cmx ocollection.cmx +ocollection/osetpt.cmo: oset.cmi ocollection.cmi +ocollection/osetpt.cmx: oset.cmx ocollection.cmx +ocollection/oassoc_buffer.cmi: ocollection.cmi oassoc.cmi +ocollection/oassocbdb.cmi: ocollection.cmi oassoc.cmi +ocollection/oassocbdb_string.cmi: ocollection.cmi oassoc.cmi +ocollection/oassocdbm.cmi: ocollection.cmi oassoc.cmi common.cmi +ocollection/ograph2way.cmi: oset.cmi ograph.cmi diff --git a/commons/Makefile b/commons/Makefile index c5878f5..b30a105 100644 --- a/commons/Makefile +++ b/commons/Makefile @@ -9,10 +9,10 @@ MYSRC=common.ml common_extra.ml \ ocollection.ml \ seti.ml \ oset.ml oassoc.ml osequence.ml ograph.ml \ - oseti.ml oseth.ml osetb.ml osetpt.ml \ - oassocb.ml oassoch.ml oassoc_buffer.ml oassocid.ml \ + ocollection/oseti.ml ocollection/oseth.ml ocollection/osetb.ml ocollection/osetpt.ml \ + ocollection/oassocb.ml ocollection/oassoch.ml ocollection/oassoc_buffer.ml ocollection/oassocid.ml \ oarray.ml \ - ograph2way.ml ograph_extended.ml \ + ocollection/ograph2way.ml ograph_extended.ml \ ofullcommon.ml \ glimpse.ml parser_combinators.ml @@ -27,29 +27,29 @@ SRC+=ocamlextra/suffix_tree.ml ocamlextra/suffix_tree_ext.ml SYSLIBS=str.cma unix.cma -INCLUDEDIRS=ocamlextra -SUBDIR=ocamlextra +INCLUDEDIRS=ocamlextra ocollection +SUBDIRS=ocamlextra ocollection #----------------------------------------------------------------------------- # Other common (thin wrapper) libraries #----------------------------------------------------------------------------- #gdbm -MYGDBMSRC=oassocdbm.ml +MYGDBMSRC=ocollection/oassocdbm.ml GDBMSYSLIBS=dbm.cma -#berkeley db +#berkeley db (ocamlbdb) BDBINCLUDES=-I ../ocamlbdb -MYBDBSRC=oassocbdb.ml +MYBDBSRC=ocollection/oassocbdb.ml ocollection/oassocbdb_string.ml BDBSYSLIBS=bdb.cma -#ocamlgtk +#lablgtk (ocamlgtk) GUIINCLUDES=-I +lablgtk2 -I +lablgtksourceview -I ../ocamlgtk/src MYGUISRC=gui.ml GUISYSLIBS=lablgtk.cma lablgtksourceview.cma -#pycaml +#pycaml (ocamlpython) PYINCLUDES=-I ../ocamlpython -I ../../ocamlpython MYPYSRC=python.ml PYSYSLIBS=python.cma @@ -59,6 +59,13 @@ MPIINCLUDES=-I ../ocamlmpi -I ../../ocamlmpi -I +ocamlmpi MYMPISRC=distribution.ml MPISYSLIBS=mpi.cma + +#----------------------------------------------------------------------------- +#pcre +#REGEXPINCLUDES=-I +pcre +REGEXPINCLUDES=-I ../ocamlpcre/lib +MYREGEXPSRC=regexp.ml + #----------------------------------------------------------------------------- # Other stuff #----------------------------------------------------------------------------- @@ -135,6 +142,7 @@ clean:: all_libs: gdbm bdb gui mpi backtrace +#----------------------------------------------------------------------------- gdbm: commons_gdbm.cma gdbm.opt: commons_gdbm.cmxa @@ -145,6 +153,7 @@ commons_gdbm.cmxa: $(MYGDBMSRC:.ml=.cmx) $(OCAMLOPT) -a -o $@ $^ +#----------------------------------------------------------------------------- bdb: $(MAKE) INCLUDESEXTRA="$(BDBINCLUDES)" commons_bdb.cma bdb.opt: @@ -158,6 +167,7 @@ commons_bdb.cmxa: $(MYBDBSRC:.ml=.cmx) +#----------------------------------------------------------------------------- gui: $(MAKE) INCLUDESEXTRA="$(GUIINCLUDES)" commons_gui.cma gui.opt: @@ -171,6 +181,7 @@ commons_gui.cmxa: $(MYGUISRC:.ml=.cmx) +#----------------------------------------------------------------------------- mpi: $(MAKE) INCLUDESEXTRA="$(MPIINCLUDES)" commons_mpi.cma mpi.opt: @@ -188,6 +199,7 @@ distribution.opt: mpi.opt +#----------------------------------------------------------------------------- python: $(MAKE) INCLUDESEXTRA="$(PYINCLUDES)" commons_python.cma python.opt: @@ -201,6 +213,20 @@ commons_python.cmxa: $(MYPYSRC:.ml=.cmx) $(OCAMLOPT) -a -o $@ $^ +#----------------------------------------------------------------------------- +regexp: + $(MAKE) INCLUDESEXTRA="$(REGEXPINCLUDES)" commons_regexp.cma +regexp.opt: + $(MAKE) INCLUDESEXTRA="$(REGEXPINCLUDES)" commons_regexp.cmxa + +commons_regexp.cma: $(MYREGEXPSRC:.ml=.cmo) + $(OCAMLC) -a -o $@ $^ + +commons_regexp.cmxa: $(MYREGEXPSRC:.ml=.cmx) + $(OCAMLOPT) -a -o $@ $^ + + +#----------------------------------------------------------------------------- backtrace: commons_backtrace.cma backtrace.opt: commons_backtrace.cmxa @@ -259,12 +285,14 @@ clean:: rm -f *~ .*~ #*# clean:: - rm -f $(SUBDIR)/*.cm[iox] $(SUBDIR)/*.o $(SUBDIR)/*.a - rm -f $(SUBDIR)/*.cma $(SUBDIR)/*.cmxa $(SUBDIR)/*.annot - rm -f $(SUBDIR)/*~ $(SUBDIR)/.*~ #*# + for i in $(SUBDIRS); do (cd $$i; \ + rm -f *.cm[iox] *.o *.a *.cma *.cmxa *.annot *~ .*~ ; \ + cd ..; ) \ + done depend: - $(OCAMLDEP) *.mli *.ml $(SUBDIR)/*.ml $(SUBDIR)/*.mli > .depend + $(OCAMLDEP) *.mli *.ml > .depend + for i in $(SUBDIRS); do ocamldep $$i/*.ml $$i/*.mli >> .depend; done distclean:: rm -f .depend diff --git a/commons/common.ml b/commons/common.ml index d891cc5..807b72c 100644 --- a/commons/common.ml +++ b/commons/common.ml @@ -50,6 +50,7 @@ * - List.rev, List.mem, List.partition, * - List.fold*, List.concat, ... * - Str.global_replace + * - Filename.is_relative * * * The Format library allows to hide passing an indent_level variable. @@ -59,7 +60,7 @@ * * Extra packages * - ocamlbdb - * - ocamlgtk + * - ocamlgtk, and gtksourceview * - ocamlgl * - ocamlpython * - ocamlagrep @@ -67,7 +68,10 @@ * - ocamlmpi * - ocamlcalendar * - * Many functions were inspired by Haskell or Lisp librairies. + * - pcre + * - sdl + * + * Many functions in this file were inspired by Haskell or Lisp librairies. *) (*****************************************************************************) @@ -1190,6 +1194,14 @@ let memoized h k f = v end +let cache_in_ref myref f = + match !myref with + | Some e -> e + | None -> + let e = f () in + myref := Some e; + e + let once f = let already = ref false in (fun x -> @@ -1274,6 +1286,8 @@ exception Impossible exception Here exception ReturnExn +exception MultiFound + exception WrongFormat of string (* old: let _TODO () = failwith "TODO", now via fix_caml with raise Todo *) @@ -1304,6 +1318,8 @@ let warning s v = (pr2 ("Warning: " ^ s ^ "; value = " ^ (dump v)); v) let exn_to_s exn = Printexc.to_string exn +(* alias *) +let string_of_exn exn = exn_to_s exn (* want or of merd, but cant cos cant put die ... in b (strict call) *) @@ -1380,9 +1396,12 @@ let check_stack_nbfiles nbfiles = * -taxo_file arg2 -sample_file arg3 -parse_c arg1. * * - * Why not use the toplevel ? because to debug ocamldebug is far superior - * to the toplevel (can go back, can go directly to a specific point, etc). - * I want a kind of testing at cmdline level. + * Why not use the toplevel ? + * - because to debug, ocamldebug is far superior to the toplevel + * (can go back, can go directly to a specific point, etc). + * I want a kind of testing at cmdline level. + * - Also I don't have file completion when in the ocaml toplevel. + * I have to type "/path/to/xxx" without help. * * * Why having variable flags ? Why use 'if !verbose_parsing then ...' ? @@ -1807,6 +1826,21 @@ let pourcent_float x total = let pourcent_float_of_floats x total = (x *. 100.0) /. total + +let pourcent_good_bad good bad = + (good * 100) / (good + bad) + +let pourcent_good_bad_float good bad = + (float_of_int good *. 100.0) /. (float_of_int good +. float_of_int bad) + +type 'a max_with_elem = int ref * 'a ref +let update_max_with_elem (aref, aelem) ~is_better (newv, newelem) = + if is_better newv aref + then begin + aref := newv; + aelem := newelem; + end + (*****************************************************************************) (* Numeric/overloading *) (*****************************************************************************) @@ -1956,19 +1990,31 @@ let map_find f xs = (*****************************************************************************) -(* Regexp *) +(* Regexp, can also use PCRE *) (*****************************************************************************) +(* Note: OCaml Str regexps are different from Perl regexp: + * - The OCaml regexp must match the entire way. + * So "testBee" =~ "Bee" is wrong + * but "testBee" =~ ".*Bee" is right + * Can have the perl behavior if use Str.search_forward instead of + * Str.string_match. + * - Must add some additional \ in front of some special char. So use + * \\( \\| and also \\b + * - It does not always handle newlines very well. + * - \\b does consider _ but not numbers in indentifiers. + * + * Note: PCRE regexps are then different from Str regexps ... + * - just use '(' ')' for grouping, not '\\)' + * - still need \\b for word boundary, but this time it works ... + * so can match some word that have some digits in them. + * + *) + (* put before String section because String section use some =~ *) (* let gsubst = global_replace *) -(* Different from Perl a little. Must match the entire way. - * So "testBee" =~ "Bee" is wrong - * but "testBee" =~ ".*Bee" is right - * Can have the perl behavior if use Str.search_forward instead of - * Str.string_match. - *) let (==~) s re = Str.string_match re s 0 @@ -1994,6 +2040,21 @@ let string_match_substring re s = try let _i = Str.search_forward re s 0 in true with Not_found -> false +let _ = + example(string_match_substring (Str.regexp "foo") "a foo b") +let _ = + example(string_match_substring (Str.regexp "\\bfoo\\b") "a foo b") +let _ = + example(string_match_substring (Str.regexp "\\bfoo\\b") "a\n\nfoo b") +let _ = + example(string_match_substring (Str.regexp "\\bfoo_bar\\b") "a\n\nfoo_bar b") +(* does not work :( +let _ = + example(string_match_substring (Str.regexp "\\bfoo_bar2\\b") "a\n\nfoo_bar2 b") +*) + + + let (regexp_match: string -> string -> string) = fun s re -> assert(s =~ re); Str.matched_group 1 s @@ -2149,6 +2210,15 @@ let plural i s = let showCodeHex xs = List.iter (fun i -> printf "%02x" i) xs +let take_string n s = + String.sub s 0 (n-1) + +let take_string_safe n s = + if n > String.length s + then s + else take_string n s + + (* used by LFS *) let size_mo_ko i = @@ -2345,6 +2415,8 @@ let relative_to_absolute s = then Sys.getcwd () ^ "/" ^ s else s +let is_relative s = Filename.is_relative s +let is_absolute s = not (is_relative s) (* @Pre: prj_path must not contain regexp symbol *) @@ -2372,6 +2444,8 @@ type langage = (* Dates *) (*****************************************************************************) +(* maybe I should use ocamlcalendar, but I don't like all those functors ... *) + type month = | Jan | Feb | Mar | Apr | May | Jun | Jul | Aug | Sep | Oct | Nov | Dec @@ -2903,6 +2977,10 @@ let cat file = in cat_aux [] () +> List.rev +> (fun x -> close_in chan; x) +let cat_array file = + (""::cat file) +> Array.of_list + + let interpolate str = begin command2 ("printf \"%s\\n\" " ^ str ^ ">/tmp/caml"); @@ -2959,12 +3037,18 @@ let cmd_to_list_and_status = process_output_to_list2 * let command2 s = ignore(Sys.command s) *) + +let _batch_mode = ref false let command2_y_or_no cmd = - pr2 (cmd ^ " [y/n] ?"); - match read_line () with - | "y" | "yes" | "Y" -> command2 cmd; true - | "n" | "no" | "N" -> false - | _ -> failwith "answer by yes or no" + if !_batch_mode then begin command2 cmd; true end + else begin + + pr2 (cmd ^ " [y/n] ?"); + match read_line () with + | "y" | "yes" | "Y" -> command2 cmd; true + | "n" | "no" | "N" -> false + | _ -> failwith "answer by yes or no" + end @@ -3310,6 +3394,14 @@ let exn_to_real_unixexit f = +let uncat xs file = + with_open_outfile file (fun (pr,_chan) -> + xs +> List.iter (fun s -> pr s; pr "\n"); + + ) + + + @@ -3921,6 +4013,10 @@ let _ = assert_equal (cartesian_product [1;2] ["3";"4";"5"]) [1,"3";1,"4";1,"5"; 2,"3";2,"4";2,"5"] + +let sort_by_val_descending xs = + List.sort (fun (k1,v1) (k2,v2) -> compare v2 v1) xs + (*----------------------------------*) (* sur surEnsemble [p1;p2] [[p1;p2;p3] [p1;p2] ....] -> [[p1;p2;p3] ... *) @@ -3996,11 +4092,79 @@ let array_find_index f a = try array_find_index_ 0 with _ -> raise Not_found +(*****************************************************************************) +(* Matrix *) +(*****************************************************************************) + type 'a matrix = 'a array array let map_matrix f mat = mat +> Array.map (fun arr -> arr +> Array.map f) +let (make_matrix_init: + nrow:int -> ncolumn:int -> (int -> int -> 'a) -> 'a matrix) = + fun ~nrow ~ncolumn f -> + Array.init nrow (fun i -> + Array.init ncolumn (fun j -> + f i j + ) + ) + +let iter_matrix f m = + Array.iteri (fun i e -> + Array.iteri (fun j x -> + f i j x + ) e + ) m + +let nb_rows_matrix m = + Array.length m + +let nb_columns_matrix m = + assert(Array.length m > 0); + Array.length m.(0) + +(* check all nested arrays have the same size *) +let invariant_matrix m = + raise Todo + +let (rows_of_matrix: 'a matrix -> 'a list list) = fun m -> + Array.to_list m +> List.map Array.to_list + +let (columns_of_matrix: 'a matrix -> 'a list list) = fun m -> + let nbcols = nb_columns_matrix m in + let nbrows = nb_rows_matrix m in + (enum 0 (nbcols -1)) +> List.map (fun j -> + (enum 0 (nbrows -1)) +> List.map (fun i -> + m.(i).(j) + )) + + +let all_elems_matrix_by_row m = + rows_of_matrix m +> List.flatten + + +let ex_matrix1 = + [| + [|0;1;2|]; + [|3;4;5|]; + [|6;7;8|]; + |] +let ex_rows1 = + [ + [0;1;2]; + [3;4;5]; + [6;7;8]; + ] +let ex_columns1 = + [ + [0;3;6]; + [1;4;7]; + [2;5;8]; + ] +let _ = example (rows_of_matrix ex_matrix1 = ex_rows1) +let _ = example (columns_of_matrix ex_matrix1 = ex_columns1) + (*****************************************************************************) (* Fast array *) @@ -4336,11 +4500,15 @@ let hkeys h = -let group_assoc_bykey_eff xs = +let group_assoc_bykey_eff2 xs = let h = Hashtbl.create 101 in xs +> List.iter (fun (k, v) -> Hashtbl.add h k v); let keys = hkeys h in keys +> List.map (fun k -> k, Hashtbl.find_all h k) + +let group_assoc_bykey_eff xs = + profile_code2 "Common.group_assoc_bykey_eff" (fun () -> + group_assoc_bykey_eff2 xs) let test_group_assoc () = @@ -4352,6 +4520,13 @@ let test_group_assoc () = pr2_gen ys +let uniq_eff xs = + let h = Hashtbl.create 101 in + xs +> List.iter (fun k -> + Hashtbl.add h k true + ); + hkeys h + let diff_two_say_set_eff xs1 xs2 = @@ -4387,6 +4562,12 @@ let (push: 'a -> 'a stack -> 'a stack) = fun x xs -> x::xs let (top: 'a stack -> 'a) = List.hd let (pop: 'a stack -> 'a stack) = List.tl +let top_option = function + | [] -> None + | x::xs -> Some x + + + (* now in prelude: * let push2 v l = l := v :: !l @@ -4400,6 +4581,46 @@ let pop2 l = end +(*****************************************************************************) +(* Undoable Stack *) +(*****************************************************************************) + +(* Okasaki use such structure also for having efficient data structure + * supporting fast append. + *) + +type 'a undo_stack = 'a list * 'a list (* redo *) + +let (empty_undo_stack: 'a undo_stack) = + [], [] + +(* push erase the possible redo *) +let (push_undo: 'a -> 'a undo_stack -> 'a undo_stack) = fun x (undo,redo) -> + x::undo, [] + +let (top_undo: 'a undo_stack -> 'a) = fun (undo, redo) -> + List.hd undo + +let (pop_undo: 'a undo_stack -> 'a undo_stack) = fun (undo, redo) -> + match undo with + | [] -> failwith "empty undo stack" + | x::xs -> + xs, x::redo + +let (undo_pop: 'a undo_stack -> 'a undo_stack) = fun (undo, redo) -> + match redo with + | [] -> failwith "empty redo, nothing to redo" + | x::xs -> + x::undo, xs + +let redo_undo x = undo_pop x + + +let top_undo_option = fun (undo, redo) -> + match undo with + | [] -> None + | x::xs -> Some x + (*****************************************************************************) (* Binary tree *) (*****************************************************************************) @@ -4431,9 +4652,17 @@ type ('a, 'b) treeref = | NodeRef of 'a * ('a, 'b) treeref list ref | LeafRef of 'b +let treeref_children_ref tree = + match tree with + | LeafRef _ -> failwith "treeref_tail: leaf" + | NodeRef (n, x) -> x + + + let rec (treeref_node_iter: (('a * ('a, 'b) treeref list ref) -> unit) -> - ('a, 'b) treeref -> unit) = fun f tree -> + ('a, 'b) treeref -> unit) = + fun f tree -> match tree with | LeafRef _ -> () | NodeRef (n, xs) -> @@ -4443,7 +4672,8 @@ let rec (treeref_node_iter: let rec (treeref_node_iter_with_parents: (('a * ('a, 'b) treeref list ref) -> ('a list) -> unit) -> - ('a, 'b) treeref -> unit) = fun f tree -> + ('a, 'b) treeref -> unit) = + fun f tree -> let rec aux acc tree = match tree with | LeafRef _ -> () @@ -4464,7 +4694,35 @@ let find_treeref f tree = match !res with | [n,xs] -> NodeRef (n, xs) | [] -> raise Not_found - | x::y::zs -> failwith "multi found" + | x::y::zs -> raise MultiFound + + +let find_treeref_with_parents_some f tree = + let res = ref [] in + + tree +> treeref_node_iter_with_parents (fun (n, xs) parents -> + match f (n,xs) parents with + | Some v -> push2 v res; + | None -> () + ); + match !res with + | [v] -> v + | [] -> raise Not_found + | x::y::zs -> raise MultiFound + +let find_multi_treeref_with_parents_some f tree = + let res = ref [] in + + tree +> treeref_node_iter_with_parents (fun (n, xs) parents -> + match f (n,xs) parents with + | Some v -> push2 v res; + | None -> () + ); + match !res with + | [v] -> !res + | [] -> raise Not_found + | x::y::zs -> !res + (*****************************************************************************) (* Graph. Have a look too at Ograph_*.mli *) @@ -5279,6 +5537,8 @@ let cmdline_flags_other () = [ "-nocheck_stack", Arg.Clear check_stack, " "; + "-batch_mode", Arg.Set _batch_mode, + " no interactivity" ] (* potentially other common options but not yet integrated: diff --git a/commons/common.mli b/commons/common.mli index 04fdd01..7932331 100644 --- a/commons/common.mli +++ b/commons/common.mli @@ -389,6 +389,8 @@ val finalize : (unit -> 'a) -> (unit -> 'b) -> 'a val memoized : ('a, 'b) Hashtbl.t -> 'a -> (unit -> 'b) -> 'b +val cache_in_ref : 'a option ref -> (unit -> 'a) -> 'a + (* take file from which computation is done, an extension, and the function * and will compute the function only once and then save result in @@ -439,6 +441,8 @@ exception Impossible exception Here exception ReturnExn +exception MultiFound + exception WrongFormat of string @@ -448,6 +452,8 @@ val warning : string -> 'a -> 'a val error_cant_have : 'a -> 'b val exn_to_s : exn -> string +(* alias *) +val string_of_exn : exn -> string (*****************************************************************************) (* Environment *) @@ -647,6 +653,12 @@ val pourcent: int -> int -> int val pourcent_float: int -> int -> float val pourcent_float_of_floats: float -> float -> float +val pourcent_good_bad: int -> int -> int +val pourcent_good_bad_float: int -> int -> float + +type 'a max_with_elem = int ref * 'a ref +val update_max_with_elem: + 'a max_with_elem -> is_better:(int -> int ref -> bool) -> int * 'a -> unit (*****************************************************************************) (* Numeric/overloading *) (*****************************************************************************) @@ -770,6 +782,9 @@ val chop_dirsymbol : string -> string val ( ) : string -> int * int -> string val ( ) : string -> int -> char +val take_string: int -> string -> string +val take_string_safe: int -> string -> string + val split_on_char : char -> string -> string list val lowercase : string -> string @@ -866,6 +881,9 @@ val normalize_path : filename -> filename val relative_to_absolute : filename -> filename +val is_relative: filename -> bool +val is_absolute: filename -> bool + val filename_without_leading_path : string -> filename -> filename (*****************************************************************************) @@ -989,6 +1007,9 @@ val nblines : string -> int (*****************************************************************************) val cat : filename -> string list val cat_orig : filename -> string list +val cat_array: filename -> string array + +val uncat: string list -> filename -> unit val interpolate : string -> string list @@ -1001,6 +1022,7 @@ val cmd_to_list : string -> string list (* alias *) val cmd_to_list_and_status : string -> string list * Unix.process_status val command2 : string -> unit +val _batch_mode: bool ref val command2_y_or_no : string -> bool val do_in_fork : (unit -> unit) -> int @@ -1136,7 +1158,10 @@ val groupBy : ('a -> 'a -> bool) -> 'a list -> 'a list list val exclude_but_keep_attached: ('a -> bool) -> 'a list -> ('a * 'a list) list val group_by_post: ('a -> bool) -> 'a list -> ('a list * 'a) list * 'a list -(* use hash internally to not be in O(n2) *) +(* Use hash internally to not be in O(n2). If you want to use it on a + * simple list, then first do a List.map to generate a key, for instance the + * first char of the element, and then use this function. + *) val group_assoc_bykey_eff : ('a * 'b) list -> ('a * 'b list) list val splitAt : int -> 'a list -> 'a list * 'a list @@ -1209,6 +1234,8 @@ val exclude : ('a -> bool) -> 'a list -> 'a list * line. Here we delete any repeated line (here list element). *) val uniq : 'a list -> 'a list +val uniq_eff: 'a list -> 'a list + val doublon : 'a list -> bool val reverse : 'a list -> 'a list (* alias *) @@ -1261,6 +1288,7 @@ val pack_sorted : ('a -> 'a -> bool) -> 'a list -> 'a list list val keep_best : ('a * 'a -> 'a option) -> 'a list -> 'a list val sorted_keep_best : ('a -> 'a -> 'a option) -> 'a list -> 'a list + val cartesian_product : 'a list -> 'b list -> ('a * 'b) list (* old stuff *) @@ -1277,10 +1305,28 @@ val fusionneListeContenant : 'a * 'a -> 'a list list -> 'a list list val array_find_index : ('a -> bool) -> 'a array -> int +(*****************************************************************************) +(* Matrix *) +(*****************************************************************************) + type 'a matrix = 'a array array val map_matrix : ('a -> 'b) -> 'a matrix -> 'b matrix +val make_matrix_init: + nrow:int -> ncolumn:int -> (int -> int -> 'a) -> 'a matrix + +val iter_matrix: + (int -> int -> 'a -> unit) -> 'a matrix -> unit + +val nb_rows_matrix: 'a matrix -> int +val nb_columns_matrix: 'a matrix -> int + +val rows_of_matrix: 'a matrix -> 'a list list +val columns_of_matrix: 'a matrix -> 'a list list + +val all_elems_matrix_by_row: 'a matrix -> 'a list + (*****************************************************************************) (* Fast array *) (*****************************************************************************) @@ -1404,6 +1450,8 @@ val lookup_list2 : 'a -> ('a, 'b) assoc list -> 'b * int val assoc_option : 'a -> ('a, 'b) assoc -> 'b option val assoc_with_err_msg : 'a -> ('a, 'b) assoc -> 'b +val sort_by_val_descending: ('a,'b) assoc -> ('a * 'b) list + (*****************************************************************************) (* Assoc, specialized. *) (*****************************************************************************) @@ -1511,9 +1559,25 @@ val push : 'a -> 'a stack -> 'a stack val top : 'a stack -> 'a val pop : 'a stack -> 'a stack +val top_option: 'a stack -> 'a option + val push2 : 'a -> 'a stack ref -> unit val pop2: 'a stack ref -> 'a +(*****************************************************************************) +(* Stack with undo/redo support *) +(*****************************************************************************) + +type 'a undo_stack = 'a list * 'a list +val empty_undo_stack : 'a undo_stack +val push_undo : 'a -> 'a undo_stack -> 'a undo_stack +val top_undo : 'a undo_stack -> 'a +val pop_undo : 'a undo_stack -> 'a undo_stack +val redo_undo: 'a undo_stack -> 'a undo_stack +val undo_pop: 'a undo_stack -> 'a undo_stack + +val top_undo_option: 'a undo_stack -> 'a option + (*****************************************************************************) (* Binary tree *) @@ -1551,8 +1615,15 @@ val find_treeref: (('a * ('a, 'b) treeref list ref) -> bool) -> ('a, 'b) treeref -> ('a, 'b) treeref +val treeref_children_ref: ('a, 'b) treeref -> ('a, 'b) treeref list ref +val find_treeref_with_parents_some: + ('a * ('a, 'b) treeref list ref -> 'a list -> 'c option) -> + ('a, 'b) treeref -> 'c +val find_multi_treeref_with_parents_some: + ('a * ('a, 'b) treeref list ref -> 'a list -> 'c option) -> + ('a, 'b) treeref -> 'c list (*****************************************************************************) @@ -1786,6 +1857,8 @@ val add_in_scope_h : ('a, 'b) scoped_h_env ref -> 'a * 'b -> unit (* Terminal (LFS) *) (*****************************************************************************) +(* don't forget to call Common_extra.set_link () *) + val _execute_and_show_progress_func : (int (* length *) -> ((unit -> unit) -> unit) -> unit) ref val execute_and_show_progress : diff --git a/commons/common_extra.ml b/commons/common_extra.ml index 8111afa..8091494 100644 --- a/commons/common_extra.ml +++ b/commons/common_extra.ml @@ -10,6 +10,14 @@ *) +(* how to use it ? ex in LFS: + * Common.execute_and_show_progress (w.prop_iprop#length) (fun k -> + * w.prop_iprop#iter (fun (p, ip) -> + * k (); + * ... + * )); + * + *) let execute_and_show_progress len f = let _count = ref 0 in @@ -19,10 +27,16 @@ let execute_and_show_progress len f = ANSITerminal.set_cursor 1 (-1); ANSITerminal.printf [] "%d / %d" !_count len; flush stdout; in + let nothing () = () in + ANSITerminal.printf [] "0 / %d" len; flush stdout; - f continue_pourcentage; + if !Common._batch_mode + then f nothing + else f continue_pourcentage + ; Common.pr2 "" + let set_link () = Common._execute_and_show_progress_func := execute_and_show_progress diff --git a/commons/glimpse.ml b/commons/glimpse.ml index afe2a44..f69879b 100644 --- a/commons/glimpse.ml +++ b/commons/glimpse.ml @@ -1,10 +1,31 @@ open Common (*****************************************************************************) -(* Glimpse *) +(* Types *) (*****************************************************************************) (* was first used for LFS, then a little for cocci, and then for aComment *) +type glimpse_search = + (* -i insensitive search *) + | GlimpseCaseInsensitive + (* -w match on complete words. But not always good idea, for instance + * if file contain chazarain_j then dont work with -w + *) + | GlimpseWholeWord + +let default_glimpse_search = [GlimpseWholeWord] + +let s_of_glimpse_search = function + | GlimpseCaseInsensitive -> "-i" + | GlimpseWholeWord -> "-w" + + +type glimpsedir = Common.dirname + +(*****************************************************************************) +(* Helpers *) +(*****************************************************************************) + let check_have_glimpse () = let xs = Common.cmd_to_list ("glimpse -V") +> Common.exclude Common.null_string in @@ -14,6 +35,13 @@ let check_have_glimpse () = | _ -> failwith "glimpse not found or bad version" ) +let s_of_glimpse_options xs = + xs +> List.map s_of_glimpse_search +> Common.join " " + + +(*****************************************************************************) +(* Indexing *) +(*****************************************************************************) (* * note: @@ -30,6 +58,8 @@ let check_have_glimpse () = * the case of compressed file first * - -F receive the list of files to index from stdin * - -H target index dir + * - -n for indexing numbers as sometimes some glimpse request are looking + * for a number * * * Note que glimpseindex index pas forcement tous les fichiers texte. @@ -43,34 +73,32 @@ let check_have_glimpse () = * ex: glimpseindex -o -H . home * *) +let glimpse_cmd s = spf "glimpseindex -o -H %s -n -F" s + let glimpseindex ext dir indexdir = check_have_glimpse (); Common.command2(spf "mkdir -p %s" indexdir); Common.command2 - (spf "find %s -name \"*.%s\" | glimpseindex -o -H %s -F" - dir ext indexdir + (spf "find %s -name \"*.%s\" | %s" + dir ext (glimpse_cmd indexdir) ); () +let _tmpfile = "/tmp/pad_glimpseindex_files.list" -type glimpse_search = - (* -i insensitive search *) - | GlimpseCaseInsensitive - (* -w match on complete words. But not always good idea, for instance - * if file contain chazarain_j then dont work with -w - *) - | GlimpseWholeWord - -let default_glimpse_search = [GlimpseWholeWord] - - +let glimpseindex_files files indexdir = + check_have_glimpse (); + Common.command2(spf "mkdir -p %s" indexdir); + + Common.uncat files _tmpfile; + Common.command2 + (spf "cat %s | %s" _tmpfile (glimpse_cmd indexdir)); + () -let s_of_glimpse_search = function - | GlimpseCaseInsensitive -> "-i" - | GlimpseWholeWord -> "-w" -let s_of_glimpse_options xs = - xs +> List.map s_of_glimpse_search +> Common.join " " +(*****************************************************************************) +(* Searching *) +(*****************************************************************************) (* note: @@ -98,7 +126,7 @@ let s_of_glimpse_options xs = * ex: glimpse -y -H . -N -W -w pattern;pattern2 * *) -let glimpse query ?(options= default_glimpse_search) dir = +let glimpse query ?(options=default_glimpse_search) dir = let str_options = s_of_glimpse_options options in let res = Common.cmd_to_list @@ -108,3 +136,11 @@ let glimpse query ?(options= default_glimpse_search) dir = (* grep -i -l -I *) let grep query = raise Todo + + +(* +check_have_position_index + +let glimpseindex_position: string -> ... (filename * int) list +let glimpse_position: string -> ... (filename * int) list +*) diff --git a/commons/oarray.ml b/commons/oarray.ml index 875ff51..ac421e8 100644 --- a/commons/oarray.ml +++ b/commons/oarray.ml @@ -32,6 +32,9 @@ object(o: 'o) method last = raise Todo method first = raise Todo method delkey = raise Todo + + method keys = raise Todo + method del = raise Todo method fromlist = raise Todo method length = diff --git a/commons/oarray.mli b/commons/oarray.mli index cec6952..387634a 100644 --- a/commons/oarray.mli +++ b/commons/oarray.mli @@ -20,6 +20,8 @@ object ('o) method assoc : int -> 'a method delkey : int -> 'o + method keys: int list + (* osequence concrete instantiation of virtual methods *) method first : 'a method last : 'a diff --git a/commons/oassoc.ml b/commons/oassoc.ml index b64241e..d6638ba 100644 --- a/commons/oassoc.ml +++ b/commons/oassoc.ml @@ -1,3 +1,5 @@ +open Common + open Ocollection (* assoc, also called map or dictionnary *) @@ -15,7 +17,11 @@ object(o: 'o) (* pre: must not be in *) (* method add: ('a * 'b) -> 'o = *) - (* method virtual keys: 'a oset *) + (* + method keys = + List.map fst (o#tolist) + *) + method virtual keys: 'a list (* or 'a oset ? *) method find: 'a -> 'b = fun k -> o#assoc k @@ -37,4 +43,8 @@ object(o: 'o) in o#replkey (k, f old) + method apply_with_default2 = fun k f default -> + o#apply_with_default k f default +> ignore + + end diff --git a/commons/oassoc.mli b/commons/oassoc.mli index 50b533b..c257e14 100644 --- a/commons/oassoc.mli +++ b/commons/oassoc.mli @@ -11,7 +11,13 @@ object ('o) method haskey : 'a -> bool method replkey : 'a * 'b -> 'o + (* better to implement it yourself *) + method virtual keys: 'a list + method apply : 'a -> ('b -> 'b) -> 'o method apply_with_default : 'a -> ('b -> 'b) -> (unit -> 'b) -> 'o + (* effect version *) + method apply_with_default2 : 'a -> ('b -> 'b) -> (unit -> 'b) -> unit + end diff --git a/commons/ocollection.ml b/commons/ocollection.ml index 38e4b96..e6b2a3d 100644 --- a/commons/ocollection.ml +++ b/commons/ocollection.ml @@ -74,6 +74,12 @@ object(o: 'o) method add2: 'a -> unit = fun a -> o#add a +> ignore; () + method del2: 'a -> unit = fun a -> + o#del a +> ignore; + () + method clear: unit = + o#iter (fun e -> o#del2 e); + diff --git a/commons/ocollection.mli b/commons/ocollection.mli index c23dced..6ab9595 100644 --- a/commons/ocollection.mli +++ b/commons/ocollection.mli @@ -19,6 +19,8 @@ object ('o) (* effect version *) method add2: 'a -> unit + method del2: 'a -> unit + method clear: unit method fold : ('c -> 'a -> 'c) -> 'c -> 'c diff --git a/commons/oassoc_buffer.ml b/commons/ocollection/oassoc_buffer.ml similarity index 62% rename from commons/oassoc_buffer.ml rename to commons/ocollection/oassoc_buffer.ml index b9f63a5..345f051 100644 --- a/commons/oassoc_buffer.ml +++ b/commons/ocollection/oassoc_buffer.ml @@ -10,6 +10,24 @@ open Osetb * every 100 operation do a flush * * todo: choose between oassocb and oassoch ? + * + * Also take care that must often redefine all function in the original + * oassoc.ml because if some methods are not redefined, for instance + * #clear, then if do wrapper over a oassocdbm, then even if oassocdbm + * redefine #clear, it will not be called, but instead the default + * method will be called that internally will call another method. + * So better delegate all the methods and override even the method + * with a default definition. + * + * In the same way sometimes an exn can occur at wierd time. When + * we add an element, sometimes this may raise an exn such as Out_of_memory, + * but as we dont add directly but only at flush time, the exn + * may happen far later the user added something in this oassoc. + * Also in the case of Out_of_memory, even if the entry is not + * added in the wrapped, it will still be present in the cache + * and so the next flush will still generate an exn that again + * may not be cached. So for the moment if Out_of_memory then + * do something special and erase the entry in the cache. *) (* !!take care!!: this class has side effect, not a pure oassoc *) @@ -24,17 +42,32 @@ object(o) val wrapped = ref cached method private myflush = + + let has_a_raised = ref false in + !dirty#iter (fun k -> - wrapped := !wrapped#add (k, !cache#assoc k) + try + wrapped := !wrapped#add (k, !cache#assoc k) + with Out_of_memory -> + pr2 "PBBBBBB: Out_of_memory in oassoc_buffer, but still empty cache"; + has_a_raised := true; ); dirty := (new osetb Setb.empty); cache := (new oassocb []); counter := 0; + if !has_a_raised then raise Out_of_memory + method misc_op_hook2 = o#myflush method empty = raise Todo + + (* what happens in k is already present ? or if add multiple times + * the same k ? cache is a oassocb and so the previous binding is + * still there, but dirty is a set, and in myflush we iter based + * on dirty so we will flush only the last 'k' in the cache. + *) method add (k,v) = cache := !cache#add (k,v); dirty := !dirty#add k; @@ -47,6 +80,15 @@ object(o) !wrapped#iter f + method keys = + o#myflush; (* bugfix: have to flush !!! *) + !wrapped#keys + + method clear = + o#myflush; (* bugfix: have to flush !!! *) + !wrapped#clear + + method length = o#myflush; !wrapped#length diff --git a/commons/oassoc_buffer.mli b/commons/ocollection/oassoc_buffer.mli similarity index 91% rename from commons/oassoc_buffer.mli rename to commons/ocollection/oassoc_buffer.mli index 3b4712b..9cff0d7 100644 --- a/commons/oassoc_buffer.mli +++ b/commons/ocollection/oassoc_buffer.mli @@ -2,7 +2,9 @@ class ['a, 'b] oassoc_buffer : int -> (< add : 'a * 'b -> 'd; assoc : 'a -> 'b; del : 'a * 'b -> 'd; - delkey : 'a -> 'd; iter : ('a * 'b -> unit) -> unit; length : int; .. > + delkey : 'a -> 'd; iter : ('a * 'b -> unit) -> unit; length : int; + keys: 'a list; clear: unit; + .. > as 'd) -> object ('o) inherit ['a,'b] Oassoc.oassoc @@ -22,7 +24,11 @@ object ('o) method assoc : 'a -> 'b method delkey : 'a -> 'o + method keys: 'a list + (* ugly, from objet class, extension trick *) method private myflush : unit method misc_op_hook2 : unit + + end diff --git a/commons/oassocb.ml b/commons/ocollection/oassocb.ml similarity index 92% rename from commons/oassocb.ml rename to commons/ocollection/oassocb.ml index f218b46..fdbddc6 100644 --- a/commons/oassocb.ml +++ b/commons/ocollection/oassocb.ml @@ -20,5 +20,8 @@ class ['a,'b] oassocb xs = method assoc k = Mapb.find k data method delkey k = {< data = Mapb.remove k data >} + + method keys = + List.map fst (o#tolist) end diff --git a/commons/oassocbdb.ml b/commons/ocollection/oassocbdb.ml similarity index 62% rename from commons/oassocbdb.ml rename to commons/ocollection/oassocbdb.ml index 17dea84..6d09410 100644 --- a/commons/oassocbdb.ml +++ b/commons/ocollection/oassocbdb.ml @@ -21,7 +21,7 @@ object(o) method empty = raise Todo - method private add2 (k,v) = + method private addbis (k,v) = (* pr2 (fkey k); *) (* pr2 (debugv v); *) @@ -30,12 +30,19 @@ object(o) with Not_found -> ()); *) let k' = Marshal.to_string k [] in - let v' = Marshal.to_string (fv v) [Marshal.Closures] in (* still clos? *) + let v' = + try + Marshal.to_string (fv v) [(*Marshal.Closures*)] + with Out_of_memory -> + pr2 ("PBBBBBBB Out_of_memory in: " ^ namedb); + raise Out_of_memory + + in (* still clos? *) Db.put data (transact()) k' v' []; (* minsky wrapper ? Db.put data ~txn:(transact()) ~key:k' ~data:v' *) o method add x = - Common.profile_code ("Btree.add" ^ namedb) (fun () -> o#add2 x) + Common.profile_code ("Btree.add" ^ namedb) (fun () -> o#addbis x) (* bugfix: if not tail call (because of a try for instance), * then strange behaviour in native mode @@ -116,4 +123,61 @@ object(o) method delkey x = Common.profile_code ("Btree.delkey" ^ namedb) (fun () -> o#delkey2 x) + + method keys = + let res = ref [] in + let dbc = Cursor.db_cursor db (transact()) [] in + let rec aux dbc = + if + (try + let a = Cursor.dbc_get dbc [Cursor.DB_NEXT] in + (* minsky ? Cursor.get dbc Cursor.NEXT [] *) + let key = (* unkey *) Marshal.from_string (fst a) 0 in + (* + let valu = unv (Marshal.from_string (snd a) 0) in + f (key, valu); + *) + Common.push2 key res; + true + with Failure "ending" -> false + ) + then aux dbc + else () + + in + aux dbc; + Cursor.dbc_close dbc (* minsky Cursor.close dbc *); + !res + + + method clear = + let dbc = Cursor.db_cursor db (transact()) [] in + let rec aux dbc = + if + (try + let a = Cursor.dbc_get dbc [Cursor.DB_NEXT] in + Db.del data (transact()) (fst a) []; + true + with Failure "ending" -> false + ) + then aux dbc + else () + + in + aux dbc; + Cursor.dbc_close dbc (* minsky Cursor.close dbc *); + () + end + + +let create_bdb metapath dbname env transact (fv, unv) size_buffer_oassoc_buffer = + let db = Bdb.Db.create env [] in + Bdb.Db.db_open db (transact()) + (spf "%s/%s.db4" metapath dbname) + (spf "/%s.db4" dbname) + Bdb.Db.DB_BTREE [Bdb.Db.DB_CREATE] 0; + db, + new Oassoc_buffer.oassoc_buffer size_buffer_oassoc_buffer + (new oassoc_btree db dbname transact fv unv) + diff --git a/commons/oassocbdb.mli b/commons/ocollection/oassocbdb.mli similarity index 59% rename from commons/oassocbdb.mli rename to commons/ocollection/oassocbdb.mli index 7978e80..b01a4ab 100644 --- a/commons/oassocbdb.mli +++ b/commons/ocollection/oassocbdb.mli @@ -1,4 +1,11 @@ -(* !!take care!!: this class does side effect, not a pure oassoc *) +(* !!take care!!: this class does side effect, not a pure oassoc. + * + * Also can not put structure with ref or mutable field because when + * you will modify those refs or fields, you will modify it in the memory, + * not in the disk. The only way to modify on the disk is to call + * #add or #replace with what you modified. Oassocbdb has no way + * to know that you modified it. + *) class ['a,'b] oassoc_btree : Bdb.db -> string (* db name, for profiling *) -> @@ -22,4 +29,15 @@ object('o) method assoc : 'a -> 'b method delkey : 'a -> 'o + method keys: 'a list + end + +val create_bdb: + string -> + string -> + Bdb.dbenv -> + (unit -> Bdb.dbtxn option) -> + ('a -> 'b) * ('c -> 'a) -> + int -> + Bdb.db * ('d, 'a) Oassoc_buffer.oassoc_buffer diff --git a/commons/ocollection/oassocbdb_string.ml b/commons/ocollection/oassocbdb_string.ml new file mode 100644 index 0000000..8682abf --- /dev/null +++ b/commons/ocollection/oassocbdb_string.ml @@ -0,0 +1,171 @@ +open Common + +(* specialisation of oassocbdb that avoids some marshaling cost *) + +open Bdb + +open Oassoc + +(* !!take care!!: this class does side effect, not a pure oassoc + *) +class ['b] oassoc_btree_string db namedb transact = +let namedb = if namedb = "" then "" else "(" ^ namedb ^ ")" in +object(o) + inherit [string,'b] oassoc + + val data = db + + method empty = + raise Todo + + method private addbis (k,v) = + let k' = k in + let v' = + try Marshal.to_string v [] + with Out_of_memory -> + pr2 ("PBBBBBBB Out_of_memory in: " ^ namedb); + raise Out_of_memory + + in (* still clos? *) + Db.put data (transact()) k' v' []; + o + method add x = + Common.profile_code ("Btree.add" ^ namedb) (fun () -> o#addbis x) + + (* bugfix: if not tail call (because of a try for instance), + * then strange behaviour in native mode + *) + method private iter2 f = + let dbc = Cursor.db_cursor db (transact()) [] in + (* minsky wrapper? Cursor.create ~writecursor:false ~txn:(transact()) db *) + let rec aux dbc = + if + (try + let a = Cursor.dbc_get dbc [Cursor.DB_NEXT] in + (* minsky ? Cursor.get dbc Cursor.NEXT [] *) + let key = (fst a) in + let valu = (Marshal.from_string (snd a) 0) in + f (key, valu); + true + with Failure "ending" -> false + ) + then aux dbc + else () + + in + aux dbc; + Cursor.dbc_close dbc (* minsky Cursor.close dbc *) + + method iter x = + Common.profile_code ("Btree.iter" ^ namedb) (fun () -> o#iter2 x) + + method view = + raise Todo + + + + method private length2 = + let dbc = Cursor.db_cursor db (transact()) [] in + + let count = ref 0 in + let rec aux dbc = + if ( + try + let _a = Cursor.dbc_get dbc [Cursor.DB_NEXT] in + incr count; + true + with Failure "ending" -> false + ) + then aux dbc + else () + + in + aux dbc; + Cursor.dbc_close dbc; + !count + + method length = + Common.profile_code ("Btree.length" ^ namedb) (fun () -> o#length2) + + + method del (k,v) = raise Todo + method mem e = raise Todo + method null = raise Todo + + method private assoc2 k = + try + let k' = k in + let vget = Db.get data (transact()) k' [] in + (* minsky ? Db.get data ~txn:(transact() *) + (Marshal.from_string vget 0) + with Not_found -> + log3 ("pb assoc with k = " ^ (k)); + raise Not_found + method assoc x = + Common.profile_code ("Btree.assoc" ^ namedb) (fun () -> o#assoc2 x) + + method private delkey2 k = + let k' = k in + Db.del data (transact()) k' []; + o + method delkey x = + Common.profile_code ("Btree.delkey" ^ namedb) (fun () -> o#delkey2 x) + + + method keys = + let res = ref [] in + let dbc = Cursor.db_cursor db (transact()) [] in + let rec aux dbc = + if + (try + let a = Cursor.dbc_get dbc [Cursor.DB_NEXT] in + (* minsky ? Cursor.get dbc Cursor.NEXT [] *) + let key = (fst a) in + (* + let valu = unv (Marshal.from_string (snd a) 0) in + f (key, valu); + *) + Common.push2 key res; + true + with Failure "ending" -> false + ) + then aux dbc + else () + + in + aux dbc; + Cursor.dbc_close dbc (* minsky Cursor.close dbc *); + !res + + + method clear = + let dbc = Cursor.db_cursor db (transact()) [] in + let rec aux dbc = + if + (try + let a = Cursor.dbc_get dbc [Cursor.DB_NEXT] in + Db.del data (transact()) (fst a) []; + true + with Failure "ending" -> false + ) + then aux dbc + else () + + in + aux dbc; + Cursor.dbc_close dbc (* minsky Cursor.close dbc *); + () + +end + + +let create_bdb metapath dbname env transact size_buffer_oassoc_buffer = + let db = Bdb.Db.create env [] in + Bdb.Db.db_open db (transact()) + (spf "%s/%s.db4" metapath dbname) + (spf "/%s.db4" dbname) + Bdb.Db.DB_BTREE [Bdb.Db.DB_CREATE] 0; + db, + new Oassoc_buffer.oassoc_buffer size_buffer_oassoc_buffer + (new oassoc_btree_string db dbname transact) + diff --git a/commons/ocollection/oassocbdb_string.mli b/commons/ocollection/oassocbdb_string.mli new file mode 100644 index 0000000..d1f3c59 --- /dev/null +++ b/commons/ocollection/oassocbdb_string.mli @@ -0,0 +1,41 @@ +(* !!take care!!: this class does side effect, not a pure oassoc. + * + * Also can not put structure with ref or mutable field because when + * you will modify those refs or fields, you will modify it in the memory, + * not in the disk. The only way to modify on the disk is to call + * #add or #replace with what you modified. Oassocbdb has no way + * to know that you modified it. + *) +class ['b] oassoc_btree_string : + Bdb.db -> + string (* db name, for profiling *) -> + (unit -> Bdb.dbtxn option) (* transaction handler *) -> +object('o) + inherit [string,'b] Oassoc.oassoc + + (* ocollection concrete instantiation of virtual methods *) + method empty : 'o + method add : string * 'b -> 'o + + method iter : (string * 'b -> unit) -> unit + method view : (string * 'b, 'o) Ocollection.view + + method del : string * 'b -> 'o + method mem : string * 'b -> bool + method null : bool + + (* oassoc concrete instantiation of virtual methods *) + method assoc : string -> 'b + method delkey : string -> 'o + + method keys: string list + +end + +val create_bdb: + string -> + string -> + Bdb.dbenv -> + (unit -> Bdb.dbtxn option) -> + int -> + Bdb.db * (string, 'a) Oassoc_buffer.oassoc_buffer diff --git a/commons/oassocdbm.ml b/commons/ocollection/oassocdbm.ml similarity index 88% rename from commons/oassocdbm.ml rename to commons/ocollection/oassocdbm.ml index 30a11ab..ff6531e 100644 --- a/commons/oassocdbm.ml +++ b/commons/ocollection/oassocdbm.ml @@ -61,6 +61,19 @@ object(o) o with Dbm.Dbm_error "dbm_delete" -> raise Not_found + + method keys = + let res = ref [] in + db +> Dbm.iter (fun key data -> + let k' = (* unkey *) Marshal.from_string key 0 in + (* + let v' = unv (Marshal.from_string data 0) in + f (k', v') + *) + Common.push2 k' res; + ); + !res + end diff --git a/commons/oassocdbm.mli b/commons/ocollection/oassocdbm.mli similarity index 96% rename from commons/oassocdbm.mli rename to commons/ocollection/oassocdbm.mli index 447669a..7efe4d7 100644 --- a/commons/oassocdbm.mli +++ b/commons/ocollection/oassocdbm.mli @@ -22,6 +22,8 @@ object ('o) method assoc : 'a -> 'b method delkey : 'a -> 'o + method keys: 'a list + end val create_dbm : diff --git a/commons/oassoch.ml b/commons/ocollection/oassoch.ml similarity index 95% rename from commons/oassoch.ml rename to commons/ocollection/oassoch.ml index 43cdb07..94d5d7a 100644 --- a/commons/oassoch.ml +++ b/commons/ocollection/oassoch.ml @@ -30,5 +30,9 @@ class ['a,'b] oassoch xs = with Not_found -> (log3 ("pb assoc with k = " ^ (Dumper.dump k)); raise Not_found) method delkey k = (Hashtbl.remove data k; o) + + method keys = + List.map fst (o#tolist) + end diff --git a/commons/oassocid.ml b/commons/ocollection/oassocid.ml similarity index 88% rename from commons/oassocid.ml rename to commons/ocollection/oassocid.ml index 58171aa..df8bd2b 100644 --- a/commons/oassocid.ml +++ b/commons/ocollection/oassocid.ml @@ -17,4 +17,8 @@ class ['a] oassoc_id xs = method assoc k = k method delkey k = {< >} + + method keys = + List.map fst (o#tolist) + end diff --git a/commons/ograph2way.ml b/commons/ocollection/ograph2way.ml similarity index 100% rename from commons/ograph2way.ml rename to commons/ocollection/ograph2way.ml diff --git a/commons/ograph2way.mli b/commons/ocollection/ograph2way.mli similarity index 100% rename from commons/ograph2way.mli rename to commons/ocollection/ograph2way.mli diff --git a/commons/osetb.ml b/commons/ocollection/osetb.ml similarity index 100% rename from commons/osetb.ml rename to commons/ocollection/osetb.ml diff --git a/commons/oseth.ml b/commons/ocollection/oseth.ml similarity index 100% rename from commons/oseth.ml rename to commons/ocollection/oseth.ml diff --git a/commons/oseti.ml b/commons/ocollection/oseti.ml similarity index 100% rename from commons/oseti.ml rename to commons/ocollection/oseti.ml diff --git a/commons/osetpt.ml b/commons/ocollection/osetpt.ml similarity index 100% rename from commons/osetpt.ml rename to commons/ocollection/osetpt.ml diff --git a/copyright.txt b/copyright.txt index 9e222f9..d29bc26 100644 --- a/copyright.txt +++ b/copyright.txt @@ -18,4 +18,4 @@ notice was preserved in the affected files. This software can be distributed under another license (dual license) making it possible to use Coccinelle in a commercial software. -Contact one of the author for more information. +Contact one of the authors for more information. diff --git a/ctl/.depend b/ctl/.depend index df69418..8733390 100644 --- a/ctl/.depend +++ b/ctl/.depend @@ -2,9 +2,11 @@ ctl_engine.cmi: ../commons/ograph_extended.cmi ast_ctl.cmo pretty_print_ctl.cmi: ast_ctl.cmo wrapper_ctl.cmi: ctl_engine.cmi ast_ctl.cmo ctl_engine.cmo: pretty_print_ctl.cmi ../commons/ograph_extended.cmi \ - flag_ctl.cmo ../commons/common.cmi ast_ctl.cmo ctl_engine.cmi + flag_ctl.cmo ../globals/flag.cmo ../commons/common.cmi ast_ctl.cmo \ + ctl_engine.cmi ctl_engine.cmx: pretty_print_ctl.cmx ../commons/ograph_extended.cmx \ - flag_ctl.cmx ../commons/common.cmx ast_ctl.cmx ctl_engine.cmi + flag_ctl.cmx ../globals/flag.cmx ../commons/common.cmx ast_ctl.cmx \ + ctl_engine.cmi pretty_print_ctl.cmo: flag_ctl.cmo ../commons/common.cmi ast_ctl.cmo \ pretty_print_ctl.cmi pretty_print_ctl.cmx: flag_ctl.cmx ../commons/common.cmx ast_ctl.cmx \ diff --git a/engine/.#Makefile.1.50 b/engine/.#Makefile.1.50 new file mode 100644 index 0000000..105528d --- /dev/null +++ b/engine/.#Makefile.1.50 @@ -0,0 +1,126 @@ +# Copyright 2005-2008, Ecole des Mines de Nantes, University of Copenhagen +# Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller +# This file is part of Coccinelle. +# +# Coccinelle is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, according to version 2 of the License. +# +# Coccinelle is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with Coccinelle. If not, see . +# +# The authors reserve the right to distribute this or future versions of +# Coccinelle under other licenses. + + +############################################################################## +# Variables +############################################################################## +#TARGET=matcher +TARGET=cocciengine +CTLTARGET=engine + +SRC= flag_matcher.ml lib_engine.ml pretty_print_engine.ml \ + check_exhaustive_pattern.ml \ + check_reachability.ml \ + c_vs_c.ml isomorphisms_c_c.ml \ + cocci_vs_c.ml pattern_c.ml sgrep.ml transformation_c.ml \ + asttomember.ml asttoctl2.ml ctltotex.ml \ + postprocess_transinfo.ml ctlcocci_integration.ml + +#c_vs_c.ml +#SRC= flag_matcher.ml \ +# c_vs_c.ml cocci_vs_c.ml \ +# lib_engine.ml \ +# pattern_c.ml transformation_c.ml + +#LIBS=../commons/commons.cma ../parsing_c/parsing_c.cma +#INCLUDES= -I ../commons -I ../parsing_c +INCLUDES = -I ../commons -I ../commons/ocamlextra -I ../globals \ + -I ../ctl -I ../parsing_cocci -I ../parsing_c +LIBS=../commons/commons.cma ../globals/globals.cma \ + ../ctl/ctl.cma ../parsing_c/parsing_c.cma ../parsing_cocci/cocci_parser.cma + +SYSLIBS= str.cma unix.cma + + +# just to test asttoctl +# CTLSOURCES = lib_engine.ml pretty_print_engine.ml asttoctl.ml ctltotex.ml \ +# main.ml + +############################################################################## +# Generic variables +############################################################################## + +#for warning: -w A +#for profiling: -p -inline 0 with OCAMLOPT +OCAMLCFLAGS ?= -g -dtypes + +OCAMLC=ocamlc$(OPTBIN) $(OCAMLCFLAGS) $(INCLUDES) +OCAMLOPT=ocamlopt$(OPTBIN) $(OPTFLAGS) $(INCLUDES) +OCAMLLEX=ocamllex$(OPTBIN) #-ml +OCAMLYACC=ocamlyacc -v +OCAMLDEP=ocamldep$(OPTBIN) $(INCLUDES) +OCAMLMKTOP=ocamlmktop -g -custom $(INCLUDES) + + +OBJS = $(SRC:.ml=.cmo) +OPTOBJS = $(SRC:.ml=.cmx) + + +############################################################################## +# Top rules +############################################################################## +all: $(TARGET).cma +all.opt: $(TARGET).cmxa + +$(TARGET).cma: $(OBJS) + $(OCAMLC) -a -o $(TARGET).cma $(OBJS) + +$(TARGET).cmxa: $(OPTOBJS) $(LIBS:.cma=.cmxa) + $(OCAMLOPT) -a -o $(TARGET).cmxa $(OPTOBJS) + +$(TARGET).top: $(OBJS) $(LIBS) + $(OCAMLMKTOP) -o $(TARGET).top $(SYSLIBS) $(LIBS) $(OBJS) + +clean:: + rm -f $(TARGET).top + + + +############################################################################## +# Pad's rules +############################################################################## + +############################################################################## +# Generic rules +############################################################################## + +.SUFFIXES: .ml .mli .cmo .cmi .cmx + +.ml.cmo: + $(OCAMLC) -c $< +.mli.cmi: + $(OCAMLC) -c $< +.ml.cmx: + $(OCAMLOPT) -c $< + +.ml.mldepend: + $(OCAMLC) -i $< + +clean:: + rm -f *.cm[ioxa] *.o *.a *.cmxa *.annot +clean:: + rm -f *~ .*~ gmon.out #*# + +beforedepend:: + +depend:: beforedepend + $(OCAMLDEP) *.mli *.ml > .depend + +-include .depend diff --git a/engine/.#asttoctl2.ml.1.145 b/engine/.#asttoctl2.ml.1.145 new file mode 100644 index 0000000..6b2a340 --- /dev/null +++ b/engine/.#asttoctl2.ml.1.145 @@ -0,0 +1,2311 @@ +(* +* Copyright 2005-2008, Ecole des Mines de Nantes, University of Copenhagen +* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller +* This file is part of Coccinelle. +* +* Coccinelle is free software: you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation, according to version 2 of the License. +* +* Coccinelle is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with Coccinelle. If not, see . +* +* The authors reserve the right to distribute this or future versions of +* Coccinelle under other licenses. +*) + + +(* for MINUS and CONTEXT, pos is always None in this file *) +(*search for require*) +(* true = don't see all matched nodes, only modified ones *) +let onlyModif = ref true(*false*) + +type ex = Exists | Forall | ReverseForall +let exists = ref Forall + +module Ast = Ast_cocci +module V = Visitor_ast +module CTL = Ast_ctl + +let warning s = Printf.fprintf stderr "warning: %s\n" s + +type cocci_predicate = Lib_engine.predicate * Ast.meta_name Ast_ctl.modif +type formula = + (cocci_predicate,Ast.meta_name, Wrapper_ctl.info) Ast_ctl.generic_ctl + +let union = Common.union_set +let intersect l1 l2 = List.filter (function x -> List.mem x l2) l1 +let subset l1 l2 = List.for_all (function x -> List.mem x l2) l1 + +let foldl1 f xs = List.fold_left f (List.hd xs) (List.tl xs) +let foldr1 f xs = + let xs = List.rev xs in List.fold_left f (List.hd xs) (List.tl xs) + +let used_after = ref ([] : Ast.meta_name list) +let guard_to_strict guard = if guard then CTL.NONSTRICT else CTL.STRICT + +let saved = ref ([] : Ast.meta_name list) + +let string2var x = ("",x) + +(* --------------------------------------------------------------------- *) +(* predicates matching various nodes in the graph *) + +let ctl_and s x y = + match (x,y) with + (CTL.False,_) | (_,CTL.False) -> CTL.False + | (CTL.True,a) | (a,CTL.True) -> a + | _ -> CTL.And(s,x,y) + +let ctl_or x y = + match (x,y) with + (CTL.True,_) | (_,CTL.True) -> CTL.True + | (CTL.False,a) | (a,CTL.False) -> a + | _ -> CTL.Or(x,y) + +let ctl_or_fl x y = + match (x,y) with + (CTL.True,_) | (_,CTL.True) -> CTL.True + | (CTL.False,a) | (a,CTL.False) -> a + | _ -> CTL.Or(y,x) + +let ctl_seqor x y = + match (x,y) with + (CTL.True,_) | (_,CTL.True) -> CTL.True + | (CTL.False,a) | (a,CTL.False) -> a + | _ -> CTL.SeqOr(x,y) + +let ctl_not = function + CTL.True -> CTL.False + | CTL.False -> CTL.True + | x -> CTL.Not(x) + +let ctl_ax s = function + CTL.True -> CTL.True + | CTL.False -> CTL.False + | x -> + match !exists with + Exists -> CTL.EX(CTL.FORWARD,x) + | Forall -> CTL.AX(CTL.FORWARD,s,x) + | ReverseForall -> failwith "not supported" + +let ctl_ax_absolute s = function + CTL.True -> CTL.True + | CTL.False -> CTL.False + | x -> CTL.AX(CTL.FORWARD,s,x) + +let ctl_ex = function + CTL.True -> CTL.True + | CTL.False -> CTL.False + | x -> CTL.EX(CTL.FORWARD,x) + +(* This stays being AX even for sgrep_mode, because it is used to identify +the structure of the term, not matching the pattern. *) +let ctl_back_ax = function + CTL.True -> CTL.True + | CTL.False -> CTL.False + | x -> CTL.AX(CTL.BACKWARD,CTL.NONSTRICT,x) + +let ctl_back_ex = function + CTL.True -> CTL.True + | CTL.False -> CTL.False + | x -> CTL.EX(CTL.BACKWARD,x) + +let ctl_ef = function + CTL.True -> CTL.True + | CTL.False -> CTL.False + | x -> CTL.EF(CTL.FORWARD,x) + +let ctl_ag s = function + CTL.True -> CTL.True + | CTL.False -> CTL.False + | x -> CTL.AG(CTL.FORWARD,s,x) + +let ctl_au s x y = + match (x,!exists) with + (CTL.True,Exists) -> CTL.EF(CTL.FORWARD,y) + | (CTL.True,Forall) -> CTL.AF(CTL.FORWARD,s,y) + | (CTL.True,ReverseForall) -> failwith "not supported" + | (_,Exists) -> CTL.EU(CTL.FORWARD,x,y) + | (_,Forall) -> CTL.AU(CTL.FORWARD,s,x,y) + | (_,ReverseForall) -> failwith "not supported" + +let ctl_anti_au s x y = (* only for ..., where the quantifier is changed *) + CTL.XX + (match (x,!exists) with + (CTL.True,Exists) -> CTL.AF(CTL.FORWARD,s,y) + | (CTL.True,Forall) -> CTL.EF(CTL.FORWARD,y) + | (CTL.True,ReverseForall) -> failwith "not supported" + | (_,Exists) -> CTL.AU(CTL.FORWARD,s,x,y) + | (_,Forall) -> CTL.EU(CTL.FORWARD,x,y) + | (_,ReverseForall) -> failwith "not supported") + +let ctl_uncheck = function + CTL.True -> CTL.True + | CTL.False -> CTL.False + | x -> CTL.Uncheck x + +let label_pred_maker = function + None -> CTL.True + | Some (label_var,used) -> + used := true; + CTL.Pred(Lib_engine.PrefixLabel(label_var),CTL.Control) + +let bclabel_pred_maker = function + None -> CTL.True + | Some (label_var,used) -> + used := true; + CTL.Pred(Lib_engine.BCLabel(label_var),CTL.Control) + +let predmaker guard pred label = + ctl_and (guard_to_strict guard) (CTL.Pred pred) (label_pred_maker label) + +let aftpred = predmaker false (Lib_engine.After, CTL.Control) +let retpred = predmaker false (Lib_engine.Return, CTL.Control) +let funpred = predmaker false (Lib_engine.FunHeader, CTL.Control) +let toppred = predmaker false (Lib_engine.Top, CTL.Control) +let exitpred = predmaker false (Lib_engine.ErrorExit, CTL.Control) +let endpred = predmaker false (Lib_engine.Exit, CTL.Control) +let gotopred = predmaker false (Lib_engine.Goto, CTL.Control) +let inlooppred = predmaker false (Lib_engine.InLoop, CTL.Control) +let truepred = predmaker false (Lib_engine.TrueBranch, CTL.Control) +let falsepred = predmaker false (Lib_engine.FalseBranch, CTL.Control) +let fallpred = predmaker false (Lib_engine.FallThrough, CTL.Control) + +let aftret label_var f = ctl_or (aftpred label_var) (exitpred label_var) + +let letctr = ref 0 +let get_let_ctr _ = + let cur = !letctr in + letctr := cur + 1; + Printf.sprintf "r%d" cur + +(* --------------------------------------------------------------------- *) +(* --------------------------------------------------------------------- *) +(* Eliminate OptStm *) + +(* for optional thing with nothing after, should check that the optional thing +never occurs. otherwise the matching stops before it occurs *) +let elim_opt = + let mcode x = x in + let donothing r k e = k e in + + let fvlist l = + List.fold_left Common.union_set [] (List.map Ast.get_fvs l) in + + let mfvlist l = + List.fold_left Common.union_set [] (List.map Ast.get_mfvs l) in + + let freshlist l = + List.fold_left Common.union_set [] (List.map Ast.get_fresh l) in + + let inheritedlist l = + List.fold_left Common.union_set [] (List.map Ast.get_inherited l) in + + let savedlist l = + List.fold_left Common.union_set [] (List.map Ast.get_saved l) in + + let varlists l = + (fvlist l, mfvlist l, freshlist l, inheritedlist l, savedlist l) in + + let rec dots_list unwrapped wrapped = + match (unwrapped,wrapped) with + ([],_) -> [] + + | (Ast.Dots(_,_,_,_)::Ast.OptStm(stm)::(Ast.Dots(_,_,_,_) as u)::urest, + d0::s::d1::rest) + | (Ast.Nest(_,_,_,_,_)::Ast.OptStm(stm)::(Ast.Dots(_,_,_,_) as u)::urest, + d0::s::d1::rest) -> + let l = Ast.get_line stm in + let new_rest1 = stm :: (dots_list (u::urest) (d1::rest)) in + let new_rest2 = dots_list urest rest in + let (fv_rest1,mfv_rest1,fresh_rest1,inherited_rest1,s1) = + varlists new_rest1 in + let (fv_rest2,mfv_rest2,fresh_rest2,inherited_rest2,s2) = + varlists new_rest2 in + [d0; + {(Ast.make_term + (Ast.Disj + [{(Ast.make_term(Ast.DOTS(new_rest1))) with + Ast.node_line = l; + Ast.free_vars = fv_rest1; + Ast.minus_free_vars = mfv_rest1; + Ast.fresh_vars = fresh_rest1; + Ast.inherited = inherited_rest1; + Ast.saved_witness = s1}; + {(Ast.make_term(Ast.DOTS(new_rest2))) with + Ast.node_line = l; + Ast.free_vars = fv_rest2; + Ast.minus_free_vars = mfv_rest2; + Ast.fresh_vars = fresh_rest2; + Ast.inherited = inherited_rest2; + Ast.saved_witness = s2}])) with + Ast.node_line = l; + Ast.free_vars = fv_rest1; + Ast.minus_free_vars = mfv_rest1; + Ast.fresh_vars = fresh_rest1; + Ast.inherited = inherited_rest1; + Ast.saved_witness = s1}] + + | (Ast.OptStm(stm)::urest,_::rest) -> + let l = Ast.get_line stm in + let new_rest1 = dots_list urest rest in + let new_rest2 = stm::new_rest1 in + let (fv_rest1,mfv_rest1,fresh_rest1,inherited_rest1,s1) = + varlists new_rest1 in + let (fv_rest2,mfv_rest2,fresh_rest2,inherited_rest2,s2) = + varlists new_rest2 in + [{(Ast.make_term + (Ast.Disj + [{(Ast.make_term(Ast.DOTS(new_rest2))) with + Ast.node_line = l; + Ast.free_vars = fv_rest2; + Ast.minus_free_vars = mfv_rest2; + Ast.fresh_vars = fresh_rest2; + Ast.inherited = inherited_rest2; + Ast.saved_witness = s2}; + {(Ast.make_term(Ast.DOTS(new_rest1))) with + Ast.node_line = l; + Ast.free_vars = fv_rest1; + Ast.minus_free_vars = mfv_rest1; + Ast.fresh_vars = fresh_rest1; + Ast.inherited = inherited_rest1; + Ast.saved_witness = s1}])) with + Ast.node_line = l; + Ast.free_vars = fv_rest2; + Ast.minus_free_vars = mfv_rest2; + Ast.fresh_vars = fresh_rest2; + Ast.inherited = inherited_rest2; + Ast.saved_witness = s2}] + + | ([Ast.Dots(_,_,_,_);Ast.OptStm(stm)],[d1;_]) -> + let l = Ast.get_line stm in + let fv_stm = Ast.get_fvs stm in + let mfv_stm = Ast.get_mfvs stm in + let fresh_stm = Ast.get_fresh stm in + let inh_stm = Ast.get_inherited stm in + let saved_stm = Ast.get_saved stm in + let fv_d1 = Ast.get_fvs d1 in + let mfv_d1 = Ast.get_mfvs d1 in + let fresh_d1 = Ast.get_fresh d1 in + let inh_d1 = Ast.get_inherited d1 in + let saved_d1 = Ast.get_saved d1 in + let fv_both = Common.union_set fv_stm fv_d1 in + let mfv_both = Common.union_set mfv_stm mfv_d1 in + let fresh_both = Common.union_set fresh_stm fresh_d1 in + let inh_both = Common.union_set inh_stm inh_d1 in + let saved_both = Common.union_set saved_stm saved_d1 in + [d1; + {(Ast.make_term + (Ast.Disj + [{(Ast.make_term(Ast.DOTS([stm]))) with + Ast.node_line = l; + Ast.free_vars = fv_stm; + Ast.minus_free_vars = mfv_stm; + Ast.fresh_vars = fresh_stm; + Ast.inherited = inh_stm; + Ast.saved_witness = saved_stm}; + {(Ast.make_term(Ast.DOTS([d1]))) with + Ast.node_line = l; + Ast.free_vars = fv_d1; + Ast.minus_free_vars = mfv_d1; + Ast.fresh_vars = fresh_d1; + Ast.inherited = inh_d1; + Ast.saved_witness = saved_d1}])) with + Ast.node_line = l; + Ast.free_vars = fv_both; + Ast.minus_free_vars = mfv_both; + Ast.fresh_vars = fresh_both; + Ast.inherited = inh_both; + Ast.saved_witness = saved_both}] + + | ([Ast.Nest(_,_,_,_,_);Ast.OptStm(stm)],[d1;_]) -> + let l = Ast.get_line stm in + let rw = Ast.rewrap stm in + let rwd = Ast.rewrap stm in + let dots = Ast.Dots(Ast.make_mcode "...",[],[],[]) in + [d1;rw(Ast.Disj + [rwd(Ast.DOTS([stm])); + {(Ast.make_term(Ast.DOTS([rw dots]))) + with Ast.node_line = l}])] + + | (_::urest,stm::rest) -> stm :: (dots_list urest rest) + | _ -> failwith "not possible" in + + let stmtdotsfn r k d = + let d = k d in + Ast.rewrap d + (match Ast.unwrap d with + Ast.DOTS(l) -> Ast.DOTS(dots_list (List.map Ast.unwrap l) l) + | Ast.CIRCLES(l) -> failwith "elimopt: not supported" + | Ast.STARS(l) -> failwith "elimopt: not supported") in + + V.rebuilder + mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode + mcode + donothing donothing stmtdotsfn donothing + donothing donothing donothing donothing donothing donothing donothing + donothing donothing donothing donothing donothing + +(* --------------------------------------------------------------------- *) +(* after management *) +(* We need Guard for the following case: +<... + a + <... + b + ...> +...> +foo(); + +Here the inner <... b ...> should not go past foo. But foo is not the +"after" of the body of the outer nest, because we don't want to search for +it in the case where the body of the outer nest ends in something other +than dots or a nest. *) + +(* what is the difference between tail and end??? *) + +type after = After of formula | Guard of formula | Tail | End | VeryEnd + +let a2n = function After x -> Guard x | a -> a + +let print_ctl x = + let pp_pred (x,_) = Pretty_print_engine.pp_predicate x in + let pp_meta (_,x) = Common.pp x in + Pretty_print_ctl.pp_ctl (pp_pred,pp_meta) false x; + Format.print_newline() + +let print_after = function + After ctl -> Printf.printf "After:\n"; print_ctl ctl + | Guard ctl -> Printf.printf "Guard:\n"; print_ctl ctl + | Tail -> Printf.printf "Tail\n" + | VeryEnd -> Printf.printf "Very End\n" + | End -> Printf.printf "End\n" + +(* --------------------------------------------------------------------- *) +(* Top-level code *) + +let fresh_var _ = string2var "_v" +let fresh_pos _ = string2var "_pos" (* must be a constant *) + +let fresh_metavar _ = "_S" + +(* fvinfo is going to end up being from the whole associated statement. + it would be better if it were just the free variables in d, but free_vars.ml + doesn't keep track of free variables on + code *) +let make_meta_rule_elem d fvinfo = + let nm = fresh_metavar() in + Ast.make_meta_rule_elem nm d fvinfo + +let get_unquantified quantified vars = + List.filter (function x -> not (List.mem x quantified)) vars + +let make_seq guard l = + let s = guard_to_strict guard in + foldr1 (function rest -> function cur -> ctl_and s cur (ctl_ax s rest)) l + +let make_seq_after2 guard first rest = + let s = guard_to_strict guard in + match rest with + After rest -> ctl_and s first (ctl_ax s (ctl_ax s rest)) + | _ -> first + +let make_seq_after guard first rest = + match rest with + After rest -> make_seq guard [first;rest] + | _ -> first + +let opt_and guard first rest = + let s = guard_to_strict guard in + match first with + None -> rest + | Some first -> ctl_and s first rest + +let and_after guard first rest = + let s = guard_to_strict guard in + match rest with After rest -> ctl_and s first rest | _ -> first + +let contains_modif = + let bind x y = x or y in + let option_default = false in + let mcode r (_,_,kind,_) = + match kind with + Ast.MINUS(_,_) -> true + | Ast.PLUS -> failwith "not possible" + | Ast.CONTEXT(_,info) -> not (info = Ast.NOTHING) in + let do_nothing r k e = k e in + let rule_elem r k re = + let res = k re in + match Ast.unwrap re with + Ast.FunHeader(bef,_,fninfo,name,lp,params,rp) -> + bind (mcode r ((),(),bef,Ast.NoMetaPos)) res + | Ast.Decl(bef,_,decl) -> bind (mcode r ((),(),bef,Ast.NoMetaPos)) res + | _ -> res in + let recursor = + V.combiner bind option_default + mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode + mcode + do_nothing do_nothing do_nothing do_nothing + do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing + do_nothing rule_elem do_nothing do_nothing do_nothing do_nothing in + recursor.V.combiner_rule_elem + +(* code is not a DisjRuleElem *) +let make_match label guard code = + let v = fresh_var() in + let matcher = Lib_engine.Match(code) in + if contains_modif code && not guard + then CTL.Exists(true,v,predmaker guard (matcher,CTL.Modif v) label) + else + let iso_info = !Flag.track_iso_usage && not (Ast.get_isos code = []) in + (match (iso_info,!onlyModif,guard, + intersect !used_after (Ast.get_fvs code)) with + (false,true,_,[]) | (_,_,true,_) -> + predmaker guard (matcher,CTL.Control) label + | _ -> CTL.Exists(true,v,predmaker guard (matcher,CTL.UnModif v) label)) + +let make_raw_match label guard code = + predmaker guard (Lib_engine.Match(code),CTL.Control) label + +let rec seq_fvs quantified = function + [] -> [] + | fv1::fvs -> + let t1fvs = get_unquantified quantified fv1 in + let termfvs = + List.fold_left Common.union_set [] + (List.map (get_unquantified quantified) fvs) in + let bothfvs = Common.inter_set t1fvs termfvs in + let t1onlyfvs = Common.minus_set t1fvs bothfvs in + let new_quantified = Common.union_set bothfvs quantified in + (t1onlyfvs,bothfvs)::(seq_fvs new_quantified fvs) + +let quantify guard = + List.fold_right + (function cur -> + function code -> CTL.Exists (not guard && List.mem cur !saved,cur,code)) + +let non_saved_quantify = + List.fold_right + (function cur -> function code -> CTL.Exists (false,cur,code)) + +let intersectll lst nested_list = + List.filter (function x -> List.exists (List.mem x) nested_list) lst + +(* --------------------------------------------------------------------- *) +(* Count depth of braces. The translation of a closed brace appears deeply +nested within the translation of the sequence term, so the name of the +paren var has to take into account the names of the nested braces. On the +other hand the close brace does not escape, so we don't have to take into +account other paren variable names. *) + +(* called repetitively, which is inefficient, but less trouble than adding a +new field to Seq and FunDecl *) +let count_nested_braces s = + let bind x y = max x y in + let option_default = 0 in + let stmt_count r k s = + match Ast.unwrap s with + Ast.Seq(_,_,_,_) | Ast.FunDecl(_,_,_,_,_) -> (k s) + 1 + | _ -> k s in + let donothing r k e = k e in + let mcode r x = 0 in + let recursor = V.combiner bind option_default + mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode + mcode + donothing donothing donothing donothing + donothing donothing donothing donothing donothing donothing + donothing donothing stmt_count donothing donothing donothing in + let res = string_of_int (recursor.V.combiner_statement s) in + string2var ("p"^res) + +let labelctr = ref 0 +let get_label_ctr _ = + let cur = !labelctr in + labelctr := cur + 1; + string2var (Printf.sprintf "l%d" cur) + +(* --------------------------------------------------------------------- *) +(* annotate dots with before and after neighbors *) + +let print_bef_aft = function + Ast.WParen (re,n) -> + Printf.printf "bef/aft\n"; + Pretty_print_cocci.rule_elem "" re; + Format.print_newline() + | Ast.Other s -> + Printf.printf "bef/aft\n"; + Pretty_print_cocci.statement "" s; + Format.print_newline() + | Ast.Other_dots d -> + Printf.printf "bef/aft\n"; + Pretty_print_cocci.statement_dots d; + Format.print_newline() + +(* [] can only occur if we are in a disj, where it comes from a ? In that +case, we want to use a, which accumulates all of the previous patterns in +their entirety. *) +let rec get_before_elem sl a = + match Ast.unwrap sl with + Ast.DOTS(x) -> + let rec loop sl a = + match sl with + [] -> ([],Common.Right a) + | [e] -> + let (e,ea) = get_before_e e a in + ([e],Common.Left ea) + | e::sl -> + let (e,ea) = get_before_e e a in + let (sl,sla) = loop sl ea in + (e::sl,sla) in + let (l,a) = loop x a in + (Ast.rewrap sl (Ast.DOTS(l)),a) + | Ast.CIRCLES(x) -> failwith "not supported" + | Ast.STARS(x) -> failwith "not supported" + +and get_before sl a = + match get_before_elem sl a with + (term,Common.Left x) -> (term,x) + | (term,Common.Right x) -> (term,x) + +and get_before_whencode wc = + List.map + (function + Ast.WhenNot w -> let (w,_) = get_before w [] in Ast.WhenNot w + | Ast.WhenAlways w -> let (w,_) = get_before_e w [] in Ast.WhenAlways w + | Ast.WhenModifier(x) -> Ast.WhenModifier(x) + | Ast.WhenNotTrue w -> Ast.WhenNotTrue w + | Ast.WhenNotFalse w -> Ast.WhenNotFalse w) + wc + +and get_before_e s a = + match Ast.unwrap s with + Ast.Dots(d,w,_,aft) -> + (Ast.rewrap s (Ast.Dots(d,get_before_whencode w,a,aft)),a) + | Ast.Nest(stmt_dots,w,multi,_,aft) -> + let w = get_before_whencode w in + let (sd,_) = get_before stmt_dots a in + let a = + List.filter + (function + Ast.Other a -> + let unifies = + Unify_ast.unify_statement_dots + (Ast.rewrap s (Ast.DOTS([a]))) stmt_dots in + (match unifies with + Unify_ast.MAYBE -> false + | _ -> true) + | Ast.Other_dots a -> + let unifies = Unify_ast.unify_statement_dots a stmt_dots in + (match unifies with + Unify_ast.MAYBE -> false + | _ -> true) + | _ -> true) + a in + (Ast.rewrap s (Ast.Nest(sd,w,multi,a,aft)),[Ast.Other_dots stmt_dots]) + | Ast.Disj(stmt_dots_list) -> + let (dsl,dsla) = + List.split (List.map (function e -> get_before e a) stmt_dots_list) in + (Ast.rewrap s (Ast.Disj(dsl)),List.fold_left Common.union_set [] dsla) + | Ast.Atomic(ast) -> + (match Ast.unwrap ast with + Ast.MetaStmt(_,_,_,_) -> (s,[]) + | _ -> (s,[Ast.Other s])) + | Ast.Seq(lbrace,decls,body,rbrace) -> + let index = count_nested_braces s in + let (de,dea) = get_before decls [Ast.WParen(lbrace,index)] in + let (bd,_) = get_before body dea in + (Ast.rewrap s (Ast.Seq(lbrace,de,bd,rbrace)), + [Ast.WParen(rbrace,index)]) + | Ast.Define(header,body) -> + let (body,_) = get_before body [] in + (Ast.rewrap s (Ast.Define(header,body)), [Ast.Other s]) + | Ast.IfThen(ifheader,branch,aft) -> + let (br,_) = get_before_e branch [] in + (Ast.rewrap s (Ast.IfThen(ifheader,br,aft)), [Ast.Other s]) + | Ast.IfThenElse(ifheader,branch1,els,branch2,aft) -> + let (br1,_) = get_before_e branch1 [] in + let (br2,_) = get_before_e branch2 [] in + (Ast.rewrap s (Ast.IfThenElse(ifheader,br1,els,br2,aft)),[Ast.Other s]) + | Ast.While(header,body,aft) -> + let (bd,_) = get_before_e body [] in + (Ast.rewrap s (Ast.While(header,bd,aft)),[Ast.Other s]) + | Ast.For(header,body,aft) -> + let (bd,_) = get_before_e body [] in + (Ast.rewrap s (Ast.For(header,bd,aft)),[Ast.Other s]) + | Ast.Do(header,body,tail) -> + let (bd,_) = get_before_e body [] in + (Ast.rewrap s (Ast.Do(header,bd,tail)),[Ast.Other s]) + | Ast.Iterator(header,body,aft) -> + let (bd,_) = get_before_e body [] in + (Ast.rewrap s (Ast.Iterator(header,bd,aft)),[Ast.Other s]) + | Ast.Switch(header,lb,cases,rb) -> + let cases = + List.map + (function case_line -> + match Ast.unwrap case_line with + Ast.CaseLine(header,body) -> + let (body,_) = get_before body [] in + Ast.rewrap case_line (Ast.CaseLine(header,body)) + | Ast.OptCase(case_line) -> failwith "not supported") + cases in + (Ast.rewrap s (Ast.Switch(header,lb,cases,rb)),[Ast.Other s]) + | Ast.FunDecl(header,lbrace,decls,body,rbrace) -> + let (de,dea) = get_before decls [] in + let (bd,_) = get_before body dea in + (Ast.rewrap s (Ast.FunDecl(header,lbrace,de,bd,rbrace)),[]) + | _ -> failwith "get_before_e: not supported" + +let rec get_after sl a = + match Ast.unwrap sl with + Ast.DOTS(x) -> + let rec loop sl = + match sl with + [] -> ([],a) + | e::sl -> + let (sl,sla) = loop sl in + let (e,ea) = get_after_e e sla in + (e::sl,ea) in + let (l,a) = loop x in + (Ast.rewrap sl (Ast.DOTS(l)),a) + | Ast.CIRCLES(x) -> failwith "not supported" + | Ast.STARS(x) -> failwith "not supported" + +and get_after_whencode a wc = + List.map + (function + Ast.WhenNot w -> let (w,_) = get_after w a (*?*) in Ast.WhenNot w + | Ast.WhenAlways w -> let (w,_) = get_after_e w a in Ast.WhenAlways w + | Ast.WhenModifier(x) -> Ast.WhenModifier(x) + | Ast.WhenNotTrue w -> Ast.WhenNotTrue w + | Ast.WhenNotFalse w -> Ast.WhenNotFalse w) + wc + +and get_after_e s a = + match Ast.unwrap s with + Ast.Dots(d,w,bef,_) -> + (Ast.rewrap s (Ast.Dots(d,get_after_whencode a w,bef,a)),a) + | Ast.Nest(stmt_dots,w,multi,bef,_) -> + let w = get_after_whencode a w in + let (sd,_) = get_after stmt_dots a in + let a = + List.filter + (function + Ast.Other a -> + let unifies = + Unify_ast.unify_statement_dots + (Ast.rewrap s (Ast.DOTS([a]))) stmt_dots in + (match unifies with + Unify_ast.MAYBE -> false + | _ -> true) + | Ast.Other_dots a -> + let unifies = Unify_ast.unify_statement_dots a stmt_dots in + (match unifies with + Unify_ast.MAYBE -> false + | _ -> true) + | _ -> true) + a in + (Ast.rewrap s (Ast.Nest(sd,w,multi,bef,a)),[Ast.Other_dots stmt_dots]) + | Ast.Disj(stmt_dots_list) -> + let (dsl,dsla) = + List.split (List.map (function e -> get_after e a) stmt_dots_list) in + (Ast.rewrap s (Ast.Disj(dsl)),List.fold_left Common.union_set [] dsla) + | Ast.Atomic(ast) -> + (match Ast.unwrap ast with + Ast.MetaStmt(nm,keep,Ast.SequencibleAfterDots _,i) -> + (* check "after" information for metavar optimization *) + (* if the error is not desired, could just return [], then + the optimization (check for EF) won't take place *) + List.iter + (function + Ast.Other x -> + (match Ast.unwrap x with + Ast.Dots(_,_,_,_) | Ast.Nest(_,_,_,_,_) -> + failwith + "dots/nest not allowed before and after stmt metavar" + | _ -> ()) + | Ast.Other_dots x -> + (match Ast.undots x with + x::_ -> + (match Ast.unwrap x with + Ast.Dots(_,_,_,_) | Ast.Nest(_,_,_,_,_) -> + failwith + ("dots/nest not allowed before and after stmt "^ + "metavar") + | _ -> ()) + | _ -> ()) + | _ -> ()) + a; + (Ast.rewrap s + (Ast.Atomic + (Ast.rewrap s + (Ast.MetaStmt(nm,keep,Ast.SequencibleAfterDots a,i)))),[]) + | Ast.MetaStmt(_,_,_,_) -> (s,[]) + | _ -> (s,[Ast.Other s])) + | Ast.Seq(lbrace,decls,body,rbrace) -> + let index = count_nested_braces s in + let (bd,bda) = get_after body [Ast.WParen(rbrace,index)] in + let (de,_) = get_after decls bda in + (Ast.rewrap s (Ast.Seq(lbrace,de,bd,rbrace)), + [Ast.WParen(lbrace,index)]) + | Ast.Define(header,body) -> + let (body,_) = get_after body a in + (Ast.rewrap s (Ast.Define(header,body)), [Ast.Other s]) + | Ast.IfThen(ifheader,branch,aft) -> + let (br,_) = get_after_e branch a in + (Ast.rewrap s (Ast.IfThen(ifheader,br,aft)),[Ast.Other s]) + | Ast.IfThenElse(ifheader,branch1,els,branch2,aft) -> + let (br1,_) = get_after_e branch1 a in + let (br2,_) = get_after_e branch2 a in + (Ast.rewrap s (Ast.IfThenElse(ifheader,br1,els,br2,aft)),[Ast.Other s]) + | Ast.While(header,body,aft) -> + let (bd,_) = get_after_e body a in + (Ast.rewrap s (Ast.While(header,bd,aft)),[Ast.Other s]) + | Ast.For(header,body,aft) -> + let (bd,_) = get_after_e body a in + (Ast.rewrap s (Ast.For(header,bd,aft)),[Ast.Other s]) + | Ast.Do(header,body,tail) -> + let (bd,_) = get_after_e body a in + (Ast.rewrap s (Ast.Do(header,bd,tail)),[Ast.Other s]) + | Ast.Iterator(header,body,aft) -> + let (bd,_) = get_after_e body a in + (Ast.rewrap s (Ast.Iterator(header,bd,aft)),[Ast.Other s]) + | Ast.Switch(header,lb,cases,rb) -> + let cases = + List.map + (function case_line -> + match Ast.unwrap case_line with + Ast.CaseLine(header,body) -> + let (body,_) = get_after body [] in + Ast.rewrap case_line (Ast.CaseLine(header,body)) + | Ast.OptCase(case_line) -> failwith "not supported") + cases in + (Ast.rewrap s (Ast.Switch(header,lb,cases,rb)),[Ast.Other s]) + | Ast.FunDecl(header,lbrace,decls,body,rbrace) -> + let (bd,bda) = get_after body [] in + let (de,_) = get_after decls bda in + (Ast.rewrap s (Ast.FunDecl(header,lbrace,de,bd,rbrace)),[]) + | _ -> failwith "get_after_e: not supported" + +let preprocess_dots sl = + let (sl,_) = get_before sl [] in + let (sl,_) = get_after sl [] in + sl + +let preprocess_dots_e sl = + let (sl,_) = get_before_e sl [] in + let (sl,_) = get_after_e sl [] in + sl + +(* --------------------------------------------------------------------- *) +(* various return_related things *) + +let rec ends_in_return stmt_list = + match Ast.unwrap stmt_list with + Ast.DOTS(x) -> + (match List.rev x with + x::_ -> + (match Ast.unwrap x with + Ast.Atomic(x) -> + let rec loop x = + match Ast.unwrap x with + Ast.Return(_,_) | Ast.ReturnExpr(_,_,_) -> true + | Ast.DisjRuleElem((_::_) as l) -> List.for_all loop l + | _ -> false in + loop x + | Ast.Disj(disjs) -> List.for_all ends_in_return disjs + | _ -> false) + | _ -> false) + | Ast.CIRCLES(x) -> failwith "not supported" + | Ast.STARS(x) -> failwith "not supported" + +(* --------------------------------------------------------------------- *) +(* expressions *) + +let exptymatch l make_match make_guard_match = + let pos = fresh_pos() in + let matches_guard_matches = + List.map + (function x -> + let pos = Ast.make_mcode pos in + (make_match (Ast.set_pos x (Some pos)), + make_guard_match (Ast.set_pos x (Some pos)))) + l in + let (matches,guard_matches) = List.split matches_guard_matches in + let rec suffixes = function + [] -> [] + | x::xs -> xs::(suffixes xs) in + let prefixes = List.rev (suffixes (List.rev guard_matches)) in + let info = (* not null *) + List.map2 + (function matcher -> + function negates -> + CTL.Exists + (false,pos, + ctl_and CTL.NONSTRICT matcher + (ctl_not + (ctl_uncheck (List.fold_left ctl_or_fl CTL.False negates))))) + matches prefixes in + CTL.InnerAnd(List.fold_left ctl_or_fl CTL.False (List.rev info)) + +(* code might be a DisjRuleElem, in which case we break it apart + code might contain an Exp or Ty + this one pushes the quantifier inwards *) +let do_re_matches label guard res quantified minus_quantified = + let make_guard_match x = + let stmt_fvs = Ast.get_mfvs x in + let fvs = get_unquantified minus_quantified stmt_fvs in + non_saved_quantify fvs (make_match None true x) in + let make_match x = + let stmt_fvs = Ast.get_fvs x in + let fvs = get_unquantified quantified stmt_fvs in + quantify guard fvs (make_match None guard x) in + ctl_and CTL.NONSTRICT (label_pred_maker label) + (match List.map Ast.unwrap res with + [] -> failwith "unexpected empty disj" + | Ast.Exp(e)::rest -> exptymatch res make_match make_guard_match + | Ast.Ty(t)::rest -> exptymatch res make_match make_guard_match + | all -> + if List.exists (function Ast.Exp(_) | Ast.Ty(_) -> true | _ -> false) + all + then failwith "unexpected exp or ty"; + List.fold_left ctl_seqor CTL.False + (List.rev (List.map make_match res))) + +(* code might be a DisjRuleElem, in which case we break it apart + code doesn't contain an Exp or Ty + this one is for use when it is not practical to push the quantifier inwards + *) +let header_match label guard code : ('a, Ast.meta_name, 'b) CTL.generic_ctl = + match Ast.unwrap code with + Ast.DisjRuleElem(res) -> + let make_match = make_match None guard in + let orop = if guard then ctl_or else ctl_seqor in + ctl_and CTL.NONSTRICT (label_pred_maker label) + (List.fold_left orop CTL.False (List.map make_match res)) + | _ -> make_match label guard code + +(* --------------------------------------------------------------------- *) +(* control structures *) + +let end_control_structure fvs header body after_pred + after_checks no_after_checks (afvs,afresh,ainh,aft) after label guard = + (* aft indicates what is added after the whole if, which has to be added + to the endif node *) + let (aft_needed,after_branch) = + match aft with + Ast.CONTEXT(_,Ast.NOTHING) -> + (false,make_seq_after2 guard after_pred after) + | _ -> + let match_endif = + make_match label guard + (make_meta_rule_elem aft (afvs,afresh,ainh)) in + (true, + make_seq_after guard after_pred + (After(make_seq_after guard match_endif after))) in + let body = body after_branch in + let s = guard_to_strict guard in + (* the code *) + quantify guard fvs + (ctl_and s header + (opt_and guard + (match (after,aft_needed) with + (After _,_) (* pattern doesn't end here *) + | (_,true) (* + code added after *) -> after_checks + | _ -> no_after_checks) + (ctl_ax_absolute s body))) + +let ifthen ifheader branch ((afvs,_,_,_) as aft) after + quantified minus_quantified label llabel slabel recurse make_match guard = +(* "if (test) thn" becomes: + if(test) & AX((TrueBranch & AX thn) v FallThrough v After) + + "if (test) thn; after" becomes: + if(test) & AX((TrueBranch & AX thn) v FallThrough v (After & AXAX after)) + & EX After +*) + (* free variables *) + let (efvs,bfvs) = + match seq_fvs quantified + [Ast.get_fvs ifheader;Ast.get_fvs branch;afvs] with + [(efvs,b1fvs);(_,b2fvs);_] -> (efvs,Common.union_set b1fvs b2fvs) + | _ -> failwith "not possible" in + let new_quantified = Common.union_set bfvs quantified in + let (mefvs,mbfvs) = + match seq_fvs minus_quantified + [Ast.get_mfvs ifheader;Ast.get_mfvs branch;[]] with + [(efvs,b1fvs);(_,b2fvs);_] -> (efvs,Common.union_set b1fvs b2fvs) + | _ -> failwith "not possible" in + let new_mquantified = Common.union_set mbfvs minus_quantified in + (* if header *) + let if_header = quantify guard efvs (make_match ifheader) in + (* then branch and after *) + let lv = get_label_ctr() in + let used = ref false in + let true_branch = + make_seq guard + [truepred label; recurse branch Tail new_quantified new_mquantified + (Some (lv,used)) llabel slabel guard] in + let after_pred = aftpred label in + let or_cases after_branch = + ctl_or true_branch (ctl_or (fallpred label) after_branch) in + let (if_header,wrapper) = + if !used + then + let label_pred = CTL.Pred (Lib_engine.Label(lv),CTL.Control) in + (ctl_and CTL.NONSTRICT(*???*) if_header label_pred, + (function body -> quantify true [lv] body)) + else (if_header,function x -> x) in + wrapper + (end_control_structure bfvs if_header or_cases after_pred + (Some(ctl_ex after_pred)) None aft after label guard) + +let ifthenelse ifheader branch1 els branch2 ((afvs,_,_,_) as aft) after + quantified minus_quantified label llabel slabel recurse make_match guard = +(* "if (test) thn else els" becomes: + if(test) & AX((TrueBranch & AX thn) v + (FalseBranch & AX (else & AX els)) v After) + & EX FalseBranch + + "if (test) thn else els; after" becomes: + if(test) & AX((TrueBranch & AX thn) v + (FalseBranch & AX (else & AX els)) v + (After & AXAX after)) + & EX FalseBranch + & EX After +*) + (* free variables *) + let (e1fvs,b1fvs,s1fvs) = + match seq_fvs quantified + [Ast.get_fvs ifheader;Ast.get_fvs branch1;afvs] with + [(e1fvs,b1fvs);(s1fvs,b1afvs);_] -> + (e1fvs,Common.union_set b1fvs b1afvs,s1fvs) + | _ -> failwith "not possible" in + let (e2fvs,b2fvs,s2fvs) = + (* fvs on else? *) + match seq_fvs quantified + [Ast.get_fvs ifheader;Ast.get_fvs branch2;afvs] with + [(e2fvs,b2fvs);(s2fvs,b2afvs);_] -> + (e2fvs,Common.union_set b2fvs b2afvs,s2fvs) + | _ -> failwith "not possible" in + let bothfvs = union (union b1fvs b2fvs) (intersect s1fvs s2fvs) in + let exponlyfvs = intersect e1fvs e2fvs in + let new_quantified = union bothfvs quantified in + (* minus free variables *) + let (me1fvs,mb1fvs,ms1fvs) = + match seq_fvs minus_quantified + [Ast.get_mfvs ifheader;Ast.get_mfvs branch1;[]] with + [(e1fvs,b1fvs);(s1fvs,b1afvs);_] -> + (e1fvs,Common.union_set b1fvs b1afvs,s1fvs) + | _ -> failwith "not possible" in + let (me2fvs,mb2fvs,ms2fvs) = + (* fvs on else? *) + match seq_fvs minus_quantified + [Ast.get_mfvs ifheader;Ast.get_mfvs branch2;[]] with + [(e2fvs,b2fvs);(s2fvs,b2afvs);_] -> + (e2fvs,Common.union_set b2fvs b2afvs,s2fvs) + | _ -> failwith "not possible" in + let mbothfvs = union (union mb1fvs mb2fvs) (intersect ms1fvs ms2fvs) in + let new_mquantified = union mbothfvs minus_quantified in + (* if header *) + let if_header = quantify guard exponlyfvs (make_match ifheader) in + (* then and else branches *) + let lv = get_label_ctr() in + let used = ref false in + let true_branch = + make_seq guard + [truepred label; recurse branch1 Tail new_quantified new_mquantified + (Some (lv,used)) llabel slabel guard] in + let false_branch = + make_seq guard + [falsepred label; make_match els; + recurse branch2 Tail new_quantified new_mquantified + (Some (lv,used)) llabel slabel guard] in + let after_pred = aftpred label in + let or_cases after_branch = + ctl_or true_branch (ctl_or false_branch after_branch) in + let s = guard_to_strict guard in + let (if_header,wrapper) = + if !used + then + let label_pred = CTL.Pred (Lib_engine.Label(lv),CTL.Control) in + (ctl_and CTL.NONSTRICT(*???*) if_header label_pred, + (function body -> quantify true [lv] body)) + else (if_header,function x -> x) in + wrapper + (end_control_structure bothfvs if_header or_cases after_pred + (Some(ctl_and s (ctl_ex (falsepred label)) (ctl_ex after_pred))) + (Some(ctl_ex (falsepred label))) + aft after label guard) + +let forwhile header body ((afvs,_,_,_) as aft) after + quantified minus_quantified label recurse make_match guard = + let process _ = + (* the translation in this case is similar to that of an if with no else *) + (* free variables *) + let (efvs,bfvs) = + match seq_fvs quantified [Ast.get_fvs header;Ast.get_fvs body;afvs] with + [(efvs,b1fvs);(_,b2fvs);_] -> (efvs,Common.union_set b1fvs b2fvs) + | _ -> failwith "not possible" in + let new_quantified = Common.union_set bfvs quantified in + (* minus free variables *) + let (mefvs,mbfvs) = + match seq_fvs minus_quantified + [Ast.get_mfvs header;Ast.get_mfvs body;[]] with + [(efvs,b1fvs);(_,b2fvs);_] -> (efvs,Common.union_set b1fvs b2fvs) + | _ -> failwith "not possible" in + let new_mquantified = Common.union_set mbfvs minus_quantified in + (* loop header *) + let header = quantify guard efvs (make_match header) in + let lv = get_label_ctr() in + let used = ref false in + let body = + make_seq guard + [inlooppred label; + recurse body Tail new_quantified new_mquantified + (Some (lv,used)) (Some (lv,used)) None guard] in + let after_pred = fallpred label in + let or_cases after_branch = ctl_or body after_branch in + let (header,wrapper) = + if !used + then + let label_pred = CTL.Pred (Lib_engine.Label(lv),CTL.Control) in + (ctl_and CTL.NONSTRICT(*???*) header label_pred, + (function body -> quantify true [lv] body)) + else (header,function x -> x) in + wrapper + (end_control_structure bfvs header or_cases after_pred + (Some(ctl_ex after_pred)) None aft after label guard) in + match (Ast.unwrap body,aft) with + (Ast.Atomic(re),(_,_,_,Ast.CONTEXT(_,Ast.NOTHING))) -> + (match Ast.unwrap re with + Ast.MetaStmt((_,_,Ast.CONTEXT(_,Ast.NOTHING),_), + Type_cocci.Unitary,_,false) -> + let (efvs) = + match seq_fvs quantified [Ast.get_fvs header] with + [(efvs,_)] -> efvs + | _ -> failwith "not possible" in + quantify guard efvs (make_match header) + | _ -> process()) + | _ -> process() + +(* --------------------------------------------------------------------- *) +(* statement metavariables *) + +(* issue: an S metavariable that is not an if branch/loop body + should not match an if branch/loop body, so check that the labels + of the nodes before the first node matched by the S are different + from the label of the first node matched by the S *) +let sequencibility body label_pred process_bef_aft = function + Ast.Sequencible | Ast.SequencibleAfterDots [] -> + body + (function x -> + (ctl_and CTL.NONSTRICT (ctl_not (ctl_back_ax label_pred)) x)) + | Ast.SequencibleAfterDots l -> + (* S appears after some dots. l is the code that comes after the S. + want to search for that first, because S can match anything, while + the stuff after is probably more restricted *) + let afts = List.map process_bef_aft l in + let ors = foldl1 ctl_or afts in + ctl_and CTL.NONSTRICT + (ctl_ef (ctl_and CTL.NONSTRICT ors (ctl_back_ax label_pred))) + (body + (function x -> + ctl_and CTL.NONSTRICT (ctl_not (ctl_back_ax label_pred)) x)) + | Ast.NotSequencible -> body (function x -> x) + +let svar_context_with_add_after stmt s label quantified d ast + seqible after process_bef_aft guard fvinfo = + let label_var = (*fresh_label_var*) string2var "_lab" in + let label_pred = + CTL.Pred (Lib_engine.Label(label_var),CTL.Control) in + let prelabel_pred = + CTL.Pred (Lib_engine.PrefixLabel(label_var),CTL.Control) in + let matcher d = make_match None guard (make_meta_rule_elem d fvinfo) in + let full_metamatch = matcher d in + let first_metamatch = + matcher + (match d with + Ast.CONTEXT(pos,Ast.BEFOREAFTER(bef,_)) -> + Ast.CONTEXT(pos,Ast.BEFORE(bef)) + | Ast.CONTEXT(pos,_) -> Ast.CONTEXT(pos,Ast.NOTHING) + | Ast.MINUS(_,_) | Ast.PLUS -> failwith "not possible") in + let middle_metamatch = + matcher + (match d with + Ast.CONTEXT(pos,_) -> Ast.CONTEXT(pos,Ast.NOTHING) + | Ast.MINUS(_,_) | Ast.PLUS -> failwith "not possible") in + let last_metamatch = + matcher + (match d with + Ast.CONTEXT(pos,Ast.BEFOREAFTER(_,aft)) -> + Ast.CONTEXT(pos,Ast.AFTER(aft)) + | Ast.CONTEXT(_,_) -> d + | Ast.MINUS(_,_) | Ast.PLUS -> failwith "not possible") in + + let rest_nodes = + ctl_and CTL.NONSTRICT middle_metamatch prelabel_pred in + let left_or = (* the whole statement is one node *) + make_seq guard + [full_metamatch; and_after guard (ctl_not prelabel_pred) after] in + let right_or = (* the statement covers multiple nodes *) + make_seq guard + [first_metamatch; + ctl_au CTL.NONSTRICT + rest_nodes + (make_seq guard + [ctl_and CTL.NONSTRICT last_metamatch label_pred; + and_after guard + (ctl_not prelabel_pred) after])] in + let body f = + ctl_and CTL.NONSTRICT label_pred + (f (ctl_and CTL.NONSTRICT + (make_raw_match label false ast) (ctl_or left_or right_or))) in + let stmt_fvs = Ast.get_fvs stmt in + let fvs = get_unquantified quantified stmt_fvs in + quantify guard (label_var::fvs) + (sequencibility body label_pred process_bef_aft seqible) + +let svar_minus_or_no_add_after stmt s label quantified d ast + seqible after process_bef_aft guard fvinfo = + let label_var = (*fresh_label_var*) string2var "_lab" in + let label_pred = + CTL.Pred (Lib_engine.Label(label_var),CTL.Control) in + let prelabel_pred = + CTL.Pred (Lib_engine.PrefixLabel(label_var),CTL.Control) in + let matcher d = make_match None guard (make_meta_rule_elem d fvinfo) in + let pure_d = + (* don't have to put anything before the beginning, so don't have to + distinguish the first node. so don't have to bother about paths, + just use the label. label ensures that found nodes match up with + what they should because it is in the lhs of the andany. *) + match d with + Ast.MINUS(pos,[]) -> true + | Ast.CONTEXT(pos,Ast.NOTHING) -> true + | _ -> false in + let ender = + match (pure_d,after) with + (true,Tail) | (true,End) | (true,VeryEnd) -> + (* the label sharing makes it safe to use AndAny *) + CTL.HackForStmt(CTL.FORWARD,CTL.NONSTRICT, + ctl_and CTL.NONSTRICT label_pred + (make_raw_match label false ast), + ctl_and CTL.NONSTRICT (matcher d) prelabel_pred) + | _ -> + (* more safe but less efficient *) + let first_metamatch = matcher d in + let rest_metamatch = + matcher + (match d with + Ast.MINUS(pos,_) -> Ast.MINUS(pos,[]) + | Ast.CONTEXT(pos,_) -> Ast.CONTEXT(pos,Ast.NOTHING) + | Ast.PLUS -> failwith "not possible") in + let rest_nodes = ctl_and CTL.NONSTRICT rest_metamatch prelabel_pred in + let last_node = and_after guard (ctl_not prelabel_pred) after in + (ctl_and CTL.NONSTRICT (make_raw_match label false ast) + (make_seq guard + [first_metamatch; + ctl_au CTL.NONSTRICT rest_nodes last_node])) in + let body f = ctl_and CTL.NONSTRICT label_pred (f ender) in + let stmt_fvs = Ast.get_fvs stmt in + let fvs = get_unquantified quantified stmt_fvs in + quantify guard (label_var::fvs) + (sequencibility body label_pred process_bef_aft seqible) + +(* --------------------------------------------------------------------- *) +(* dots and nests *) + +let dots_au is_strict toend label s wrapcode x seq_after y quantifier = + let matchgoto = gotopred None in + let matchbreak = + make_match None false + (wrapcode + (Ast.Break(Ast.make_mcode "break",Ast.make_mcode ";"))) in + let matchcontinue = + make_match None false + (wrapcode + (Ast.Continue(Ast.make_mcode "continue",Ast.make_mcode ";"))) in + let stop_early = + if quantifier = Exists + then Common.Left(CTL.False) + else if toend + then Common.Left(CTL.Or(aftpred label,exitpred label)) + else if is_strict + then Common.Left(aftpred label) + else + Common.Right + (function v -> + let lv = get_label_ctr() in + let labelpred = CTL.Pred(Lib_engine.Label lv,CTL.Control) in + let preflabelpred = label_pred_maker (Some (lv,ref true)) in + ctl_or (aftpred label) + (quantify false [lv] + (ctl_and CTL.NONSTRICT + (ctl_and CTL.NONSTRICT (truepred label) labelpred) + (ctl_au CTL.NONSTRICT + (ctl_and CTL.NONSTRICT (ctl_not v) preflabelpred) + (ctl_and CTL.NONSTRICT preflabelpred + (ctl_or (retpred None) + (if !Flag_matcher.only_return_is_error_exit + then CTL.True + else + (ctl_or matchcontinue + (ctl_and CTL.NONSTRICT + (ctl_or matchgoto matchbreak) + (ctl_ag s (ctl_not seq_after))))))))))) in + let op = if quantifier = !exists then ctl_au else ctl_anti_au in + let v = get_let_ctr() in + op s x + (match stop_early with + Common.Left x -> ctl_or y x + | Common.Right stop_early -> + CTL.Let(v,y,ctl_or (CTL.Ref v) (stop_early (CTL.Ref v)))) + +let rec dots_and_nests plus nest whencodes bef aft dotcode after label + process_bef_aft statement_list statement guard quantified wrapcode = + let ctl_and_ns = ctl_and CTL.NONSTRICT in + (* proces bef_aft *) + let shortest l = + List.fold_left ctl_or_fl CTL.False (List.map process_bef_aft l) in + let bef_aft = (* to be negated *) + try + let _ = + List.find + (function Ast.WhenModifier(Ast.WhenAny) -> true | _ -> false) + whencodes in + CTL.False + with Not_found -> shortest (Common.union_set bef aft) in + let is_strict = + List.exists + (function Ast.WhenModifier(Ast.WhenStrict) -> true | _ -> false) + whencodes in + let check_quantifier quant other = + if List.exists + (function Ast.WhenModifier(x) -> x = quant | _ -> false) + whencodes + then + if List.exists + (function Ast.WhenModifier(x) -> x = other | _ -> false) + whencodes + then failwith "inconsistent annotation on dots" + else true + else false in + let quantifier = + if check_quantifier Ast.WhenExists Ast.WhenForall + then Exists + else + if check_quantifier Ast.WhenForall Ast.WhenExists + then Forall + else !exists in + (* the following is used when we find a goto, etc and consider accepting + without finding the rest of the pattern *) + let aft = shortest aft in + (* process whencode *) + let labelled = label_pred_maker label in + let whencodes arg = + let (poswhen,negwhen) = + List.fold_left + (function (poswhen,negwhen) -> + function + Ast.WhenNot whencodes -> + (poswhen,ctl_or (statement_list whencodes) negwhen) + | Ast.WhenAlways stm -> + (ctl_and CTL.NONSTRICT (statement stm) poswhen,negwhen) + | Ast.WhenModifier(_) -> (poswhen,negwhen) + | Ast.WhenNotTrue(e) -> + (poswhen, + ctl_or (whencond_true e label guard quantified) negwhen) + | Ast.WhenNotFalse(e) -> + (poswhen, + ctl_or (whencond_false e label guard quantified) negwhen)) + (CTL.True,bef_aft) (List.rev whencodes) in + let poswhen = ctl_and_ns arg poswhen in + let negwhen = +(* if !exists + then*) + (* add in After, because it's not part of the program *) + ctl_or (aftpred label) negwhen + (*else negwhen*) in + ctl_and_ns poswhen (ctl_not negwhen) in + (* process dot code, if any *) + let dotcode = + match (dotcode,guard) with + (None,_) | (_,true) -> CTL.True + | (Some dotcode,_) -> dotcode in + (* process nest code, if any *) + (* whencode goes in the negated part of the nest; if no nest, just goes + on the "true" in between code *) + let plus_var = if plus then get_label_ctr() else string2var "" in + let plus_var2 = if plus then get_label_ctr() else string2var "" in + let ornest = + match (nest,guard && not plus) with + (None,_) | (_,true) -> whencodes CTL.True + | (Some nest,false) -> + let v = get_let_ctr() in + let is_plus x = + if plus + then + (* the idea is that BindGood is sort of a witness; a witness to + having found the subterm in at least one place. If there is + not a witness, then there is a risk that it will get thrown + away, if it is merged with a node that has an empty + environment. See tests/nestplus. But this all seems + rather suspicious *) + CTL.And(CTL.NONSTRICT,x, + CTL.Exists(true,plus_var2, + CTL.Pred(Lib_engine.BindGood(plus_var), + CTL.Modif plus_var2))) + else x in + CTL.Let(v,nest, + CTL.Or(is_plus (CTL.Ref v), + whencodes (CTL.Not(ctl_uncheck (CTL.Ref v))))) in + let plus_modifier x = + if plus + then + CTL.Exists + (false,plus_var, + (CTL.And + (CTL.NONSTRICT,x, + CTL.Not(CTL.Pred(Lib_engine.BindBad(plus_var),CTL.Control))))) + else x in + + let ender = + match after with + After f -> f + | Guard f -> ctl_uncheck f + | VeryEnd -> + let exit = endpred label in + let errorexit = exitpred label in + ctl_or exit errorexit + (* not at all sure what the next two mean... *) + | End -> CTL.True + | Tail -> + (match label with + Some (lv,used) -> used := true; + ctl_or (CTL.Pred(Lib_engine.Label lv,CTL.Control)) + (ctl_back_ex (ctl_or (retpred label) (gotopred label))) + | None -> endpred label) + (* was the following, but not clear why sgrep should allow + incomplete patterns + let exit = endpred label in + let errorexit = exitpred label in + if !exists + then ctl_or exit errorexit (* end anywhere *) + else exit (* end at the real end of the function *) *) in + plus_modifier + (dots_au is_strict ((after = Tail) or (after = VeryEnd)) + label (guard_to_strict guard) wrapcode + (ctl_and_ns dotcode (ctl_and_ns ornest labelled)) + aft ender quantifier) + +and get_whencond_exps e = + match Ast.unwrap e with + Ast.Exp e -> [e] + | Ast.DisjRuleElem(res) -> + List.fold_left Common.union_set [] (List.map get_whencond_exps res) + | _ -> failwith "not possible" + +and make_whencond_headers e e1 label guard quantified = + let fvs = Ast.get_fvs e in + let header_pred h = + quantify guard (get_unquantified quantified fvs) + (make_match label guard h) in + let if_header e1 = + header_pred + (Ast.rewrap e + (Ast.IfHeader + (Ast.make_mcode "if", + Ast.make_mcode "(",e1,Ast.make_mcode ")"))) in + let while_header e1 = + header_pred + (Ast.rewrap e + (Ast.WhileHeader + (Ast.make_mcode "while", + Ast.make_mcode "(",e1,Ast.make_mcode ")"))) in + let for_header e1 = + header_pred + (Ast.rewrap e + (Ast.ForHeader + (Ast.make_mcode "for",Ast.make_mcode "(",None,Ast.make_mcode ";", + Some e1,Ast.make_mcode ";",None,Ast.make_mcode ")"))) in + let if_headers = + List.fold_left ctl_or CTL.False (List.map if_header e1) in + let while_headers = + List.fold_left ctl_or CTL.False (List.map while_header e1) in + let for_headers = + List.fold_left ctl_or CTL.False (List.map for_header e1) in + (if_headers, while_headers, for_headers) + +and whencond_true e label guard quantified = + let e1 = get_whencond_exps e in + let (if_headers, while_headers, for_headers) = + make_whencond_headers e e1 label guard quantified in + ctl_or + (ctl_and CTL.NONSTRICT (truepred label) (ctl_back_ex if_headers)) + (ctl_and CTL.NONSTRICT + (inlooppred label) (ctl_back_ex (ctl_or while_headers for_headers))) + +and whencond_false e label guard quantified = + let e1 = get_whencond_exps e in + let (if_headers, while_headers, for_headers) = + make_whencond_headers e e1 label guard quantified in + ctl_or (ctl_and CTL.NONSTRICT (falsepred label) (ctl_back_ex if_headers)) + (ctl_and CTL.NONSTRICT (fallpred label) + (ctl_or (ctl_back_ex if_headers) + (ctl_or (ctl_back_ex while_headers) (ctl_back_ex for_headers)))) + +(* --------------------------------------------------------------------- *) +(* the main translation loop *) + +let rec statement_list stmt_list after quantified minus_quantified + label llabel slabel dots_before guard = + let isdots x = + (* include Disj to be on the safe side *) + match Ast.unwrap x with + Ast.Dots _ | Ast.Nest _ | Ast.Disj _ -> true | _ -> false in + let compute_label l e db = if db or isdots e then l else None in + match Ast.unwrap stmt_list with + Ast.DOTS(x) -> + let rec loop quantified minus_quantified dots_before label llabel slabel + = function + ([],_,_) -> (match after with After f -> f | _ -> CTL.True) + | ([e],_,_) -> + statement e after quantified minus_quantified + (compute_label label e dots_before) + llabel slabel guard + | (e::sl,fv::fvs,mfv::mfvs) -> + let shared = intersectll fv fvs in + let unqshared = get_unquantified quantified shared in + let new_quantified = Common.union_set unqshared quantified in + let minus_shared = intersectll mfv mfvs in + let munqshared = + get_unquantified minus_quantified minus_shared in + let new_mquantified = + Common.union_set munqshared minus_quantified in + quantify guard unqshared + (statement e + (After + (let (label1,llabel1,slabel1) = + match Ast.unwrap e with + Ast.Atomic(re) -> + (match Ast.unwrap re with + Ast.Goto _ -> (None,None,None) + | _ -> (label,llabel,slabel)) + | _ -> (label,llabel,slabel) in + loop new_quantified new_mquantified (isdots e) + label1 llabel1 slabel1 + (sl,fvs,mfvs))) + new_quantified new_mquantified + (compute_label label e dots_before) llabel slabel guard) + | _ -> failwith "not possible" in + loop quantified minus_quantified dots_before + label llabel slabel + (x,List.map Ast.get_fvs x,List.map Ast.get_mfvs x) + | Ast.CIRCLES(x) -> failwith "not supported" + | Ast.STARS(x) -> failwith "not supported" + +(* llabel is the label of the enclosing loop and slabel is the label of the + enclosing switch *) +and statement stmt after quantified minus_quantified + label llabel slabel guard = + let ctl_au = ctl_au CTL.NONSTRICT in + let ctl_ax = ctl_ax CTL.NONSTRICT in + let ctl_and = ctl_and CTL.NONSTRICT in + let make_seq = make_seq guard in + let make_seq_after = make_seq_after guard in + let real_make_match = make_match in + let make_match = header_match label guard in + + let dots_done = ref false in (* hack for dots cases we can easily handle *) + + let term = + match Ast.unwrap stmt with + Ast.Atomic(ast) -> + (match Ast.unwrap ast with + (* the following optimisation is not a good idea, because when S + is alone, we would like it not to match a declaration. + this makes more matching for things like when (...) S, but perhaps + that matching is not so costly anyway *) + (*Ast.MetaStmt(_,Type_cocci.Unitary,_,false) when guard -> CTL.True*) + | Ast.MetaStmt((s,_,(Ast.CONTEXT(_,Ast.BEFOREAFTER(_,_)) as d),_), + keep,seqible,_) + | Ast.MetaStmt((s,_,(Ast.CONTEXT(_,Ast.AFTER(_)) as d),_), + keep,seqible,_)-> + svar_context_with_add_after stmt s label quantified d ast seqible + after + (process_bef_aft quantified minus_quantified + label llabel slabel true) + guard + (Ast.get_fvs stmt, Ast.get_fresh stmt, Ast.get_inherited stmt) + + | Ast.MetaStmt((s,_,d,_),keep,seqible,_) -> + svar_minus_or_no_add_after stmt s label quantified d ast seqible + after + (process_bef_aft quantified minus_quantified + label llabel slabel true) + guard + (Ast.get_fvs stmt, Ast.get_fresh stmt, Ast.get_inherited stmt) + + | _ -> + let term = + match Ast.unwrap ast with + Ast.DisjRuleElem(res) -> + do_re_matches label guard res quantified minus_quantified + | Ast.Exp(_) | Ast.Ty(_) -> + let stmt_fvs = Ast.get_fvs stmt in + let fvs = get_unquantified quantified stmt_fvs in + CTL.InnerAnd(quantify guard fvs (make_match ast)) + | _ -> + let stmt_fvs = Ast.get_fvs stmt in + let fvs = get_unquantified quantified stmt_fvs in + quantify guard fvs (make_match ast) in + match Ast.unwrap ast with + Ast.Break(brk,semi) -> + (match (llabel,slabel) with + (_,Some(lv,used)) -> (* use switch label if there is one *) + ctl_and term (bclabel_pred_maker slabel) + | _ -> ctl_and term (bclabel_pred_maker llabel)) + | Ast.Continue(brk,semi) -> ctl_and term (bclabel_pred_maker llabel) + | Ast.Return((_,info,retmc,pos),(_,_,semmc,_)) -> + (* discard pattern that comes after return *) + let normal_res = make_seq_after term after in + (* the following code tries to propagate the modifications on + return; to a close brace, in the case where the final return + is absent *) + let new_mc = + match (retmc,semmc) with + (Ast.MINUS(_,l1),Ast.MINUS(_,l2)) when !Flag.sgrep_mode2 -> + (* in sgrep mode, we can propagate the - *) + Some (Ast.MINUS(Ast.NoPos,l1@l2)) + | (Ast.MINUS(_,l1),Ast.MINUS(_,l2)) + | (Ast.CONTEXT(_,Ast.BEFORE(l1)), + Ast.CONTEXT(_,Ast.AFTER(l2))) -> + Some (Ast.CONTEXT(Ast.NoPos,Ast.BEFORE(l1@l2))) + | (Ast.CONTEXT(_,Ast.BEFORE(_)),Ast.CONTEXT(_,Ast.NOTHING)) + | (Ast.CONTEXT(_,Ast.NOTHING),Ast.CONTEXT(_,Ast.NOTHING)) -> + Some retmc + | (Ast.CONTEXT(_,Ast.NOTHING),Ast.CONTEXT(_,Ast.AFTER(l))) -> + Some (Ast.CONTEXT(Ast.NoPos,Ast.BEFORE(l))) + | _ -> None in + let ret = Ast.make_mcode "return" in + let edots = + Ast.rewrap ast (Ast.Edots(Ast.make_mcode "...",None)) in + let semi = Ast.make_mcode ";" in + let simple_return = + make_match(Ast.rewrap ast (Ast.Return(ret,semi))) in + let return_expr = + make_match(Ast.rewrap ast (Ast.ReturnExpr(ret,edots,semi))) in + (match new_mc with + Some new_mc -> + let exit = endpred None in + let mod_rbrace = + Ast.rewrap ast (Ast.SeqEnd (("}",info,new_mc,pos))) in + let stripped_rbrace = + Ast.rewrap ast (Ast.SeqEnd(Ast.make_mcode "}")) in + ctl_or normal_res + (ctl_and (make_match mod_rbrace) + (ctl_and + (ctl_back_ax + (ctl_not + (ctl_uncheck + (ctl_or simple_return return_expr)))) + (ctl_au + (make_match stripped_rbrace) + (* error exit not possible; it is in the middle + of code, so a return is needed *) + exit))) + | _ -> + (* some change in the middle of the return, so have to + find an actual return *) + normal_res) + | _ -> + (* should try to deal with the dots_bef_aft problem elsewhere, + but don't have the courage... *) + let term = + if guard + then term + else + do_between_dots stmt term End + quantified minus_quantified label llabel slabel guard in + dots_done := true; + make_seq_after term after) + | Ast.Seq(lbrace,decls,body,rbrace) -> + let (lbfvs,b1fvs,b2fvs,b3fvs,rbfvs) = + match + seq_fvs quantified + [Ast.get_fvs lbrace;Ast.get_fvs decls; + Ast.get_fvs body;Ast.get_fvs rbrace] + with + [(lbfvs,b1fvs);(_,b2fvs);(_,b3fvs);(rbfvs,_)] -> + (lbfvs,b1fvs,b2fvs,b3fvs,rbfvs) + | _ -> failwith "not possible" in + let (mlbfvs,mb1fvs,mb2fvs,mb3fvs,mrbfvs) = + match + seq_fvs minus_quantified + [Ast.get_mfvs lbrace;Ast.get_mfvs decls; + Ast.get_mfvs body;Ast.get_mfvs rbrace] + with + [(lbfvs,b1fvs);(_,b2fvs);(_,b3fvs);(rbfvs,_)] -> + (lbfvs,b1fvs,b2fvs,b3fvs,rbfvs) + | _ -> failwith "not possible" in + let pv = count_nested_braces stmt in + let lv = get_label_ctr() in + let paren_pred = CTL.Pred(Lib_engine.Paren pv,CTL.Control) in + let label_pred = CTL.Pred(Lib_engine.Label lv,CTL.Control) in + let start_brace = + ctl_and + (quantify guard lbfvs (make_match lbrace)) + (ctl_and paren_pred label_pred) in + let empty_rbrace = + match Ast.unwrap rbrace with + Ast.SeqEnd((data,info,_,pos)) -> + Ast.rewrap rbrace(Ast.SeqEnd(Ast.make_mcode data)) + | _ -> failwith "unexpected close brace" in + let end_brace = + (* label is not needed; paren_pred is enough *) + quantify guard rbfvs + (ctl_au (make_match empty_rbrace) + (ctl_and + (real_make_match None guard rbrace) + paren_pred)) in + let new_quantified2 = + Common.union_set b1fvs (Common.union_set b2fvs quantified) in + let new_quantified3 = Common.union_set b3fvs new_quantified2 in + let new_mquantified2 = + Common.union_set mb1fvs (Common.union_set mb2fvs minus_quantified) in + let new_mquantified3 = Common.union_set mb3fvs new_mquantified2 in + let pattern_as_given = + let new_quantified2 = Common.union_set [pv] new_quantified2 in + let new_quantified3 = Common.union_set [pv] new_quantified3 in + quantify true [pv;lv] + (quantify guard b1fvs + (make_seq + [start_brace; + quantify guard b2fvs + (statement_list decls + (After + (quantify guard b3fvs + (statement_list body + (After (make_seq_after end_brace after)) + new_quantified3 new_mquantified3 + (Some (lv,ref true)) (* label mostly useful *) + llabel slabel true guard))) + new_quantified2 new_mquantified2 + (Some (lv,ref true)) llabel slabel false guard)])) in + if ends_in_return body + then + (* matching error handling code *) + (* Cases: + 1. The pattern as given + 2. A goto, and then some close braces, and then the pattern as + given, but without the braces (only possible if there are no + decls, and open and close braces are unmodified) + 3. Part of the pattern as given, then a goto, and then the rest + of the pattern. For this case, we just check that all paths have + a goto within the current braces. checking for a goto at every + point in the pattern seems expensive and not worthwhile. *) + let pattern2 = + let body = preprocess_dots body in (* redo, to drop braces *) + make_seq + [gotopred label; + ctl_au + (make_match empty_rbrace) + (ctl_ax (* skip the destination label *) + (quantify guard b3fvs + (statement_list body End + new_quantified3 new_mquantified3 None llabel slabel + true guard)))] in + let pattern3 = + let new_quantified2 = Common.union_set [pv] new_quantified2 in + let new_quantified3 = Common.union_set [pv] new_quantified3 in + quantify true [pv;lv] + (quantify guard b1fvs + (make_seq + [start_brace; + ctl_and + (CTL.AU (* want AF even for sgrep *) + (CTL.FORWARD,CTL.STRICT, + CTL.Pred(Lib_engine.PrefixLabel(lv),CTL.Control), + ctl_and (* brace must be eventually after goto *) + (gotopred (Some (lv,ref true))) + (* want AF even for sgrep *) + (CTL.AF(CTL.FORWARD,CTL.STRICT,end_brace)))) + (quantify guard b2fvs + (statement_list decls + (After + (quantify guard b3fvs + (statement_list body Tail + (*After + (make_seq_after + nopv_end_brace after)*) + new_quantified3 new_mquantified3 + None llabel slabel true guard))) + new_quantified2 new_mquantified2 + (Some (lv,ref true)) + llabel slabel false guard))])) in + ctl_or pattern_as_given + (match Ast.unwrap decls with + Ast.DOTS([]) -> ctl_or pattern2 pattern3 + | Ast.DOTS(l) -> pattern3 + | _ -> failwith "circles and stars not supported") + else pattern_as_given + | Ast.IfThen(ifheader,branch,aft) -> + ifthen ifheader branch aft after quantified minus_quantified + label llabel slabel statement make_match guard + + | Ast.IfThenElse(ifheader,branch1,els,branch2,aft) -> + ifthenelse ifheader branch1 els branch2 aft after quantified + minus_quantified label llabel slabel statement make_match guard + + | Ast.While(header,body,aft) | Ast.For(header,body,aft) + | Ast.Iterator(header,body,aft) -> + forwhile header body aft after quantified minus_quantified + label statement make_match guard + + | Ast.Disj(stmt_dots_list) -> (* list shouldn't be empty *) + ctl_and + (label_pred_maker label) + (List.fold_left ctl_seqor CTL.False + (List.map + (function sl -> + statement_list sl after quantified minus_quantified label + llabel slabel true guard) + stmt_dots_list)) + + | Ast.Nest(stmt_dots,whencode,multi,bef,aft) -> + (* label in recursive call is None because label check is already + wrapped around the corresponding code *) + + let bfvs = + match seq_fvs quantified [Ast.get_wcfvs whencode;Ast.get_fvs stmt_dots] + with + [(wcfvs,bothfvs);(bdfvs,_)] -> bothfvs + | _ -> failwith "not possible" in + + (* no minus version because when code doesn't contain any minus code *) + let new_quantified = Common.union_set bfvs quantified in + + quantify guard bfvs + (let dots_pattern = + statement_list stmt_dots (a2n after) new_quantified minus_quantified + None llabel slabel true guard in + dots_and_nests multi + (Some dots_pattern) whencode bef aft None after label + (process_bef_aft new_quantified minus_quantified + None llabel slabel true) + (function x -> + statement_list x Tail new_quantified minus_quantified None + llabel slabel true true) + (function x -> + statement x Tail new_quantified minus_quantified None + llabel slabel true) + guard quantified + (function x -> Ast.set_fvs [] (Ast.rewrap stmt x))) + + | Ast.Dots((_,i,d,_),whencodes,bef,aft) -> + let dot_code = + match d with + Ast.MINUS(_,_) -> + (* no need for the fresh metavar, but ... is a bit wierd as a + variable name *) + Some(make_match (make_meta_rule_elem d ([],[],[]))) + | _ -> None in + dots_and_nests false None whencodes bef aft dot_code after label + (process_bef_aft quantified minus_quantified None llabel slabel true) + (function x -> + statement_list x Tail quantified minus_quantified + None llabel slabel true true) + (function x -> + statement x Tail quantified minus_quantified None llabel slabel true) + guard quantified + (function x -> Ast.set_fvs [] (Ast.rewrap stmt x)) + + | Ast.Switch(header,lb,cases,rb) -> + let rec intersect_all = function + [] -> [] + | [x] -> x + | x::xs -> intersect x (intersect_all xs) in + let rec union_all l = List.fold_left union [] l in + (* start normal variables *) + let header_fvs = Ast.get_fvs header in + let lb_fvs = Ast.get_fvs lb in + let case_fvs = List.map Ast.get_fvs cases in + let rb_fvs = Ast.get_fvs rb in + let (all_efvs,all_b1fvs,all_lbfvs,all_b2fvs, + all_casefvs,all_b3fvs,all_rbfvs) = + List.fold_left + (function (all_efvs,all_b1fvs,all_lbfvs,all_b2fvs, + all_casefvs,all_b3fvs,all_rbfvs) -> + function case_fvs -> + match seq_fvs quantified [header_fvs;lb_fvs;case_fvs;rb_fvs] with + [(efvs,b1fvs);(lbfvs,b2fvs);(casefvs,b3fvs);(rbfvs,_)] -> + (efvs::all_efvs,b1fvs::all_b1fvs,lbfvs::all_lbfvs, + b2fvs::all_b2fvs,casefvs::all_casefvs,b3fvs::all_b3fvs, + rbfvs::all_rbfvs) + | _ -> failwith "not possible") + ([],[],[],[],[],[],[]) case_fvs in + let (all_efvs,all_b1fvs,all_lbfvs,all_b2fvs, + all_casefvs,all_b3fvs,all_rbfvs) = + (List.rev all_efvs,List.rev all_b1fvs,List.rev all_lbfvs, + List.rev all_b2fvs,List.rev all_casefvs,List.rev all_b3fvs, + List.rev all_rbfvs) in + let exponlyfvs = intersect_all all_efvs in + let lbonlyfvs = intersect_all all_lbfvs in +(* don't do anything with right brace. Hope there is no + code on it *) +(* let rbonlyfvs = intersect_all all_rbfvs in*) + let b1fvs = union_all all_b1fvs in + let new1_quantified = union b1fvs quantified in + let b2fvs = union (union_all all_b1fvs) (intersect_all all_casefvs) in + let new2_quantified = union b2fvs new1_quantified in +(* let b3fvs = union_all all_b3fvs in*) + (* ------------------- start minus free variables *) + let header_mfvs = Ast.get_mfvs header in + let lb_mfvs = Ast.get_mfvs lb in + let case_mfvs = List.map Ast.get_mfvs cases in + let rb_mfvs = Ast.get_mfvs rb in + let (all_mefvs,all_mb1fvs,all_mlbfvs,all_mb2fvs, + all_mcasefvs,all_mb3fvs,all_mrbfvs) = + List.fold_left + (function (all_efvs,all_b1fvs,all_lbfvs,all_b2fvs, + all_casefvs,all_b3fvs,all_rbfvs) -> + function case_mfvs -> + match + seq_fvs quantified + [header_mfvs;lb_mfvs;case_mfvs;rb_mfvs] with + [(efvs,b1fvs);(lbfvs,b2fvs);(casefvs,b3fvs);(rbfvs,_)] -> + (efvs::all_efvs,b1fvs::all_b1fvs,lbfvs::all_lbfvs, + b2fvs::all_b2fvs,casefvs::all_casefvs,b3fvs::all_b3fvs, + rbfvs::all_rbfvs) + | _ -> failwith "not possible") + ([],[],[],[],[],[],[]) case_mfvs in + let (all_mefvs,all_mb1fvs,all_mlbfvs,all_mb2fvs, + all_mcasefvs,all_mb3fvs,all_mrbfvs) = + (List.rev all_mefvs,List.rev all_mb1fvs,List.rev all_mlbfvs, + List.rev all_mb2fvs,List.rev all_mcasefvs,List.rev all_mb3fvs, + List.rev all_mrbfvs) in +(* don't do anything with right brace. Hope there is no + code on it *) +(* let rbonlyfvs = intersect_all all_rbfvs in*) + let mb1fvs = union_all all_mb1fvs in + let new1_mquantified = union mb1fvs quantified in + let mb2fvs = union (union_all all_mb1fvs) (intersect_all all_mcasefvs) in + let new2_mquantified = union mb2fvs new1_mquantified in +(* let b3fvs = union_all all_b3fvs in*) + (* ------------------- end collection of free variables *) + let switch_header = quantify guard exponlyfvs (make_match header) in + let lb = quantify guard lbonlyfvs (make_match lb) in +(* let rb = quantify guard rbonlyfvs (make_match rb) in*) + let case_headers = + List.map + (function case_line -> + match Ast.unwrap case_line with + Ast.CaseLine(header,body) -> + let e1fvs = + match seq_fvs new2_quantified [Ast.get_fvs header] with + [(e1fvs,_)] -> e1fvs + | _ -> failwith "not possible" in + quantify guard e1fvs (real_make_match label true header) + | Ast.OptCase(case_line) -> failwith "not supported") + cases in + let no_header = + ctl_not (List.fold_left ctl_or_fl CTL.False case_headers) in + let lv = get_label_ctr() in + let used = ref false in + let case_code = + List.map + (function case_line -> + match Ast.unwrap case_line with + Ast.CaseLine(header,body) -> + let (e1fvs,b1fvs,s1fvs) = + let fvs = [Ast.get_fvs header;Ast.get_fvs body] in + match seq_fvs new2_quantified fvs with + [(e1fvs,b1fvs);(s1fvs,_)] -> (e1fvs,b1fvs,s1fvs) + | _ -> failwith "not possible" in + let (me1fvs,mb1fvs,ms1fvs) = + let fvs = [Ast.get_mfvs header;Ast.get_mfvs body] in + match seq_fvs new2_mquantified fvs with + [(e1fvs,b1fvs);(s1fvs,_)] -> (e1fvs,b1fvs,s1fvs) + | _ -> failwith "not possible" in + let case_header = + quantify guard e1fvs (make_match header) in + let new3_quantified = union b1fvs new2_quantified in + let new3_mquantified = union mb1fvs new2_mquantified in + let body = + statement_list body Tail + new3_quantified new3_mquantified label llabel + (Some (lv,used)) true(*?*) guard in + quantify guard b1fvs (make_seq [case_header; body]) + | Ast.OptCase(case_line) -> failwith "not supported") + cases in + let default_required = + if List.exists + (function case -> + match Ast.unwrap case with + Ast.CaseLine(header,_) -> + (match Ast.unwrap header with + Ast.Default(_,_) -> true + | _ -> false) + | _ -> false) + cases + then function x -> x + else function x -> ctl_or (fallpred label) x in + let after_pred = aftpred label in + let body after_branch = + ctl_or + (default_required + (quantify guard b2fvs + (make_seq + [ctl_and lb + (List.fold_left ctl_and CTL.True + (List.map ctl_ex case_headers)); + List.fold_left ctl_or_fl no_header case_code]))) + after_branch in + let aft = + (rb_fvs,Ast.get_fresh rb,Ast.get_inherited rb, + match Ast.unwrap rb with + Ast.SeqEnd(rb) -> Ast.get_mcodekind rb + | _ -> failwith "not possible") in + let (switch_header,wrapper) = + if !used + then + let label_pred = CTL.Pred (Lib_engine.Label(lv),CTL.Control) in + (ctl_and switch_header label_pred, + (function body -> quantify true [lv] body)) + else (switch_header,function x -> x) in + wrapper + (end_control_structure b1fvs switch_header body + after_pred (Some(ctl_ex after_pred)) None aft after label guard) + | Ast.FunDecl(header,lbrace,decls,body,rbrace) -> + let (hfvs,b1fvs,lbfvs,b2fvs,b3fvs,b4fvs,rbfvs) = + match + seq_fvs quantified + [Ast.get_fvs header;Ast.get_fvs lbrace;Ast.get_fvs decls; + Ast.get_fvs body;Ast.get_fvs rbrace] + with + [(hfvs,b1fvs);(lbfvs,b2fvs);(_,b3fvs);(_,b4fvs);(rbfvs,_)] -> + (hfvs,b1fvs,lbfvs,b2fvs,b3fvs,b4fvs,rbfvs) + | _ -> failwith "not possible" in + let (mhfvs,mb1fvs,mlbfvs,mb2fvs,mb3fvs,mb4fvs,mrbfvs) = + match + seq_fvs quantified + [Ast.get_mfvs header;Ast.get_mfvs lbrace;Ast.get_mfvs decls; + Ast.get_mfvs body;Ast.get_mfvs rbrace] + with + [(hfvs,b1fvs);(lbfvs,b2fvs);(_,b3fvs);(_,b4fvs);(rbfvs,_)] -> + (hfvs,b1fvs,lbfvs,b2fvs,b3fvs,b4fvs,rbfvs) + | _ -> failwith "not possible" in + let function_header = quantify guard hfvs (make_match header) in + let start_brace = quantify guard lbfvs (make_match lbrace) in + let stripped_rbrace = + match Ast.unwrap rbrace with + Ast.SeqEnd((data,info,_,_)) -> + Ast.rewrap rbrace(Ast.SeqEnd (Ast.make_mcode data)) + | _ -> failwith "unexpected close brace" in + let end_brace = + let exit = CTL.Pred (Lib_engine.Exit,CTL.Control) in + let errorexit = CTL.Pred (Lib_engine.ErrorExit,CTL.Control) in + let fake_brace = CTL.Pred (Lib_engine.FakeBrace,CTL.Control) in + ctl_and + (quantify guard rbfvs (make_match rbrace)) + (ctl_and + (* the following finds the beginning of the fake braces, + if there are any, not completely sure how this works. + sse the examples sw and return *) + (ctl_back_ex (ctl_not fake_brace)) + (ctl_au (make_match stripped_rbrace) (ctl_or exit errorexit))) in + let new_quantified3 = + Common.union_set b1fvs + (Common.union_set b2fvs (Common.union_set b3fvs quantified)) in + let new_quantified4 = Common.union_set b4fvs new_quantified3 in + let new_mquantified3 = + Common.union_set mb1fvs + (Common.union_set mb2fvs + (Common.union_set mb3fvs minus_quantified)) in + let new_mquantified4 = Common.union_set mb4fvs new_mquantified3 in + let fn_nest = + match (Ast.undots decls,Ast.undots body,contains_modif rbrace) with + ([],[body],false) -> + (match Ast.unwrap body with + Ast.Nest(stmt_dots,[],multi,_,_) -> + if multi + then None (* not sure how to optimize this case *) + else Some (Common.Left stmt_dots) + | Ast.Dots(_,whencode,_,_) when + (List.for_all + (* flow sensitive, so not optimizable *) + (function Ast.WhenNotTrue(_) | Ast.WhenNotFalse(_) -> + false + | _ -> true) whencode) -> + Some (Common.Right whencode) + | _ -> None) + | _ -> None in + let body_code = + match fn_nest with + Some (Common.Left stmt_dots) -> + (* special case for function header + body - header is unambiguous + and unique, so we can just look for the nested body anywhere + else in the CFG *) + CTL.AndAny + (CTL.FORWARD,guard_to_strict guard,start_brace, + statement_list stmt_dots + (* discards match on right brace, but don't need it *) + (Guard (make_seq_after end_brace after)) + new_quantified4 new_mquantified4 + None llabel slabel true guard) + | Some (Common.Right whencode) -> + (* try to be more efficient for the case where the body is just + ... Perhaps this is too much of a special case, but useful + for dropping a parameter and checking that it is never used. *) + make_seq + [start_brace; + match whencode with + [] -> CTL.True + | _ -> + let leftarg = + ctl_and + (ctl_not + (List.fold_left + (function prev -> + function + Ast.WhenAlways(s) -> prev + | Ast.WhenNot(sl) -> + let x = + statement_list sl Tail + new_quantified4 new_mquantified4 + label llabel slabel true true in + ctl_or prev x + | Ast.WhenNotTrue(_) | Ast.WhenNotFalse(_) -> + failwith "unexpected" + | Ast.WhenModifier(Ast.WhenAny) -> CTL.False + | Ast.WhenModifier(_) -> prev) + CTL.False whencode)) + (List.fold_left + (function prev -> + function + Ast.WhenAlways(s) -> + let x = + statement s Tail + new_quantified4 new_mquantified4 + label llabel slabel true in + ctl_and prev x + | Ast.WhenNot(sl) -> prev + | Ast.WhenNotTrue(_) | Ast.WhenNotFalse(_) -> + failwith "unexpected" + | Ast.WhenModifier(Ast.WhenAny) -> CTL.True + | Ast.WhenModifier(_) -> prev) + CTL.True whencode) in + ctl_au leftarg (make_match stripped_rbrace)] + | None -> + make_seq + [start_brace; + quantify guard b3fvs + (statement_list decls + (After + (quantify guard b4fvs + (statement_list body + (After (make_seq_after end_brace after)) + new_quantified4 new_mquantified4 + None llabel slabel true guard))) + new_quantified3 new_mquantified3 None llabel slabel + false guard)] in + quantify guard b1fvs + (make_seq [function_header; quantify guard b2fvs body_code]) + | Ast.Define(header,body) -> + let (hfvs,bfvs,bodyfvs) = + match seq_fvs quantified [Ast.get_fvs header;Ast.get_fvs body] + with + [(hfvs,b1fvs);(bodyfvs,_)] -> (hfvs,b1fvs,bodyfvs) + | _ -> failwith "not possible" in + let (mhfvs,mbfvs,mbodyfvs) = + match seq_fvs minus_quantified [Ast.get_mfvs header;Ast.get_mfvs body] + with + [(hfvs,b1fvs);(bodyfvs,_)] -> (hfvs,b1fvs,bodyfvs) + | _ -> failwith "not possible" in + let define_header = quantify guard hfvs (make_match header) in + let body_code = + statement_list body after + (Common.union_set bfvs quantified) + (Common.union_set mbfvs minus_quantified) + None llabel slabel true guard in + quantify guard bfvs (make_seq [define_header; body_code]) + | Ast.OptStm(stm) -> + failwith "OptStm should have been compiled away\n" + | Ast.UniqueStm(stm) -> failwith "arities not yet supported" + | _ -> failwith "not supported" in + if guard or !dots_done + then term + else + do_between_dots stmt term after quantified minus_quantified + label llabel slabel guard + +(* term is the translation of stmt *) +and do_between_dots stmt term after quantified minus_quantified + label llabel slabel guard = + match Ast.get_dots_bef_aft stmt with + Ast.AddingBetweenDots (brace_term,n) + | Ast.DroppingBetweenDots (brace_term,n) -> + let match_brace = + statement brace_term after quantified minus_quantified + label llabel slabel guard in + let v = Printf.sprintf "_r_%d" n in + let case1 = ctl_and CTL.NONSTRICT (CTL.Ref v) match_brace in + let case2 = ctl_and CTL.NONSTRICT (ctl_not (CTL.Ref v)) term in + CTL.Let + (v,ctl_or + (ctl_back_ex (ctl_or (truepred label) (inlooppred label))) + (ctl_back_ex (ctl_back_ex (falsepred label))), + ctl_or case1 case2) + | Ast.NoDots -> term + +(* un_process_bef_aft is because we don't want to do transformation in this + code, and thus don't case about braces before or after it *) +and process_bef_aft quantified minus_quantified label llabel slabel guard = + function + Ast.WParen (re,n) -> + let paren_pred = CTL.Pred (Lib_engine.Paren n,CTL.Control) in + let s = guard_to_strict guard in + quantify true (get_unquantified quantified [n]) + (ctl_and s (make_raw_match None guard re) paren_pred) + | Ast.Other s -> + statement s Tail quantified minus_quantified label llabel slabel guard + | Ast.Other_dots d -> + statement_list d Tail quantified minus_quantified + label llabel slabel true guard + +(* --------------------------------------------------------------------- *) +(* cleanup: convert AX to EX for pdots. +Concretely: AX(A[...] & E[...]) becomes AX(A[...]) & EX(E[...]) +This is what we wanted in the first place, but it wasn't possible to make +because the AX and its argument are not created in the same place. +Rather clunky... *) +(* also cleanup XX, which is a marker for the case where the programmer +specifies to change the quantifier on .... Assumed to only occur after one AX +or EX, or at top level. *) + +let rec cleanup c = + let c = match c with CTL.XX(c) -> c | _ -> c in + match c with + CTL.False -> CTL.False + | CTL.True -> CTL.True + | CTL.Pred(p) -> CTL.Pred(p) + | CTL.Not(phi) -> CTL.Not(cleanup phi) + | CTL.Exists(keep,v,phi) -> CTL.Exists(keep,v,cleanup phi) + | CTL.AndAny(dir,s,phi1,phi2) -> + CTL.AndAny(dir,s,cleanup phi1,cleanup phi2) + | CTL.HackForStmt(dir,s,phi1,phi2) -> + CTL.HackForStmt(dir,s,cleanup phi1,cleanup phi2) + | CTL.And(s,phi1,phi2) -> CTL.And(s,cleanup phi1,cleanup phi2) + | CTL.Or(phi1,phi2) -> CTL.Or(cleanup phi1,cleanup phi2) + | CTL.SeqOr(phi1,phi2) -> CTL.SeqOr(cleanup phi1,cleanup phi2) + | CTL.Implies(phi1,phi2) -> CTL.Implies(cleanup phi1,cleanup phi2) + | CTL.AF(dir,s,phi1) -> CTL.AF(dir,s,cleanup phi1) + | CTL.AX(CTL.FORWARD,s, + CTL.Let(v1,e1, + CTL.And(CTL.NONSTRICT,CTL.AU(CTL.FORWARD,s2,e2,e3), + CTL.EU(CTL.FORWARD,e4,e5)))) -> + CTL.Let(v1,e1, + CTL.And(CTL.NONSTRICT, + CTL.AX(CTL.FORWARD,s,CTL.AU(CTL.FORWARD,s2,e2,e3)), + CTL.EX(CTL.FORWARD,CTL.EU(CTL.FORWARD,e4,e5)))) + | CTL.AX(dir,s,CTL.XX(phi)) -> CTL.EX(dir,cleanup phi) + | CTL.EX(dir,CTL.XX((CTL.AU(_,s,_,_)) as phi)) -> + CTL.AX(dir,s,cleanup phi) + | CTL.XX(phi) -> failwith "bad XX" + | CTL.AX(dir,s,phi1) -> CTL.AX(dir,s,cleanup phi1) + | CTL.AG(dir,s,phi1) -> CTL.AG(dir,s,cleanup phi1) + | CTL.EF(dir,phi1) -> CTL.EF(dir,cleanup phi1) + | CTL.EX(dir,phi1) -> CTL.EX(dir,cleanup phi1) + | CTL.EG(dir,phi1) -> CTL.EG(dir,cleanup phi1) + | CTL.AW(dir,s,phi1,phi2) -> CTL.AW(dir,s,cleanup phi1,cleanup phi2) + | CTL.AU(dir,s,phi1,phi2) -> CTL.AU(dir,s,cleanup phi1,cleanup phi2) + | CTL.EU(dir,phi1,phi2) -> CTL.EU(dir,cleanup phi1,cleanup phi2) + | CTL.Let (x,phi1,phi2) -> CTL.Let (x,cleanup phi1,cleanup phi2) + | CTL.LetR (dir,x,phi1,phi2) -> CTL.LetR (dir,x,cleanup phi1,cleanup phi2) + | CTL.Ref(s) -> CTL.Ref(s) + | CTL.Uncheck(phi1) -> CTL.Uncheck(cleanup phi1) + | CTL.InnerAnd(phi1) -> CTL.InnerAnd(cleanup phi1) + +(* --------------------------------------------------------------------- *) +(* Function declaration *) + +let top_level name (ua,pos) t = + let ua = List.filter (function (nm,_) -> nm = name) ua in + used_after := ua; + saved := Ast.get_saved t; + let quantified = Common.minus_set ua pos in + quantify false quantified + (match Ast.unwrap t with + Ast.FILEINFO(old_file,new_file) -> failwith "not supported fileinfo" + | Ast.DECL(stmt) -> + let unopt = elim_opt.V.rebuilder_statement stmt in + let unopt = preprocess_dots_e unopt in + cleanup(statement unopt VeryEnd quantified [] None None None false) + | Ast.CODE(stmt_dots) -> + let unopt = elim_opt.V.rebuilder_statement_dots stmt_dots in + let unopt = preprocess_dots unopt in + let starts_with_dots = + match Ast.undots stmt_dots with + d::ds -> + (match Ast.unwrap d with + Ast.Dots(_,_,_,_) | Ast.Circles(_,_,_,_) + | Ast.Stars(_,_,_,_) -> true + | _ -> false) + | _ -> false in + let starts_with_brace = + match Ast.undots stmt_dots with + d::ds -> + (match Ast.unwrap d with + Ast.Seq(_) -> true + | _ -> false) + | _ -> false in + let res = + statement_list unopt VeryEnd quantified [] None None None + false false in + cleanup + (if starts_with_dots + then + (* EX because there is a loop on enter/top *) + ctl_and CTL.NONSTRICT (toppred None) (ctl_ex res) + else if starts_with_brace + then + ctl_and CTL.NONSTRICT + (ctl_not(CTL.EX(CTL.BACKWARD,(funpred None)))) res + else res) + | Ast.ERRORWORDS(exps) -> failwith "not supported errorwords") + +(* --------------------------------------------------------------------- *) +(* Entry points *) + +let asttoctlz (name,(_,_,exists_flag),l) used_after positions = + letctr := 0; + labelctr := 0; + (match exists_flag with + Ast.Exists -> exists := Exists + | Ast.Forall -> exists := Forall + | Ast.ReverseForall -> exists := ReverseForall + | Ast.Undetermined -> + exists := if !Flag.sgrep_mode2 then Exists else Forall); + + let (l,used_after) = + List.split + (List.filter + (function (t,_) -> + match Ast.unwrap t with Ast.ERRORWORDS(exps) -> false | _ -> true) + (List.combine l (List.combine used_after positions))) in + let res = List.map2 (top_level name) used_after l in + exists := Forall; + res + +let asttoctl r used_after positions = + match r with + Ast.ScriptRule _ -> [] + | Ast.CocciRule (a,b,c,_) -> asttoctlz (a,b,c) used_after positions + +let pp_cocci_predicate (pred,modif) = + Pretty_print_engine.pp_predicate pred + +let cocci_predicate_to_string (pred,modif) = + Pretty_print_engine.predicate_to_string pred diff --git a/engine/.#asttoctl2.ml.1.147 b/engine/.#asttoctl2.ml.1.147 new file mode 100644 index 0000000..990a323 --- /dev/null +++ b/engine/.#asttoctl2.ml.1.147 @@ -0,0 +1,2319 @@ +(* +* Copyright 2005-2008, Ecole des Mines de Nantes, University of Copenhagen +* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller +* This file is part of Coccinelle. +* +* Coccinelle is free software: you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation, according to version 2 of the License. +* +* Coccinelle is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with Coccinelle. If not, see . +* +* The authors reserve the right to distribute this or future versions of +* Coccinelle under other licenses. +*) + + +(* for MINUS and CONTEXT, pos is always None in this file *) +(*search for require*) +(* true = don't see all matched nodes, only modified ones *) +let onlyModif = ref true(*false*) + +type ex = Exists | Forall | ReverseForall +let exists = ref Forall + +module Ast = Ast_cocci +module V = Visitor_ast +module CTL = Ast_ctl + +let warning s = Printf.fprintf stderr "warning: %s\n" s + +type cocci_predicate = Lib_engine.predicate * Ast.meta_name Ast_ctl.modif +type formula = + (cocci_predicate,Ast.meta_name, Wrapper_ctl.info) Ast_ctl.generic_ctl + +let union = Common.union_set +let intersect l1 l2 = List.filter (function x -> List.mem x l2) l1 +let subset l1 l2 = List.for_all (function x -> List.mem x l2) l1 + +let foldl1 f xs = List.fold_left f (List.hd xs) (List.tl xs) +let foldr1 f xs = + let xs = List.rev xs in List.fold_left f (List.hd xs) (List.tl xs) + +let used_after = ref ([] : Ast.meta_name list) +let guard_to_strict guard = if guard then CTL.NONSTRICT else CTL.STRICT + +let saved = ref ([] : Ast.meta_name list) + +let string2var x = ("",x) + +(* --------------------------------------------------------------------- *) +(* predicates matching various nodes in the graph *) + +let ctl_and s x y = + match (x,y) with + (CTL.False,_) | (_,CTL.False) -> CTL.False + | (CTL.True,a) | (a,CTL.True) -> a + | _ -> CTL.And(s,x,y) + +let ctl_or x y = + match (x,y) with + (CTL.True,_) | (_,CTL.True) -> CTL.True + | (CTL.False,a) | (a,CTL.False) -> a + | _ -> CTL.Or(x,y) + +let ctl_or_fl x y = + match (x,y) with + (CTL.True,_) | (_,CTL.True) -> CTL.True + | (CTL.False,a) | (a,CTL.False) -> a + | _ -> CTL.Or(y,x) + +let ctl_seqor x y = + match (x,y) with + (CTL.True,_) | (_,CTL.True) -> CTL.True + | (CTL.False,a) | (a,CTL.False) -> a + | _ -> CTL.SeqOr(x,y) + +let ctl_not = function + CTL.True -> CTL.False + | CTL.False -> CTL.True + | x -> CTL.Not(x) + +let ctl_ax s = function + CTL.True -> CTL.True + | CTL.False -> CTL.False + | x -> + match !exists with + Exists -> CTL.EX(CTL.FORWARD,x) + | Forall -> CTL.AX(CTL.FORWARD,s,x) + | ReverseForall -> failwith "not supported" + +let ctl_ax_absolute s = function + CTL.True -> CTL.True + | CTL.False -> CTL.False + | x -> CTL.AX(CTL.FORWARD,s,x) + +let ctl_ex = function + CTL.True -> CTL.True + | CTL.False -> CTL.False + | x -> CTL.EX(CTL.FORWARD,x) + +(* This stays being AX even for sgrep_mode, because it is used to identify +the structure of the term, not matching the pattern. *) +let ctl_back_ax = function + CTL.True -> CTL.True + | CTL.False -> CTL.False + | x -> CTL.AX(CTL.BACKWARD,CTL.NONSTRICT,x) + +let ctl_back_ex = function + CTL.True -> CTL.True + | CTL.False -> CTL.False + | x -> CTL.EX(CTL.BACKWARD,x) + +let ctl_ef = function + CTL.True -> CTL.True + | CTL.False -> CTL.False + | x -> CTL.EF(CTL.FORWARD,x) + +let ctl_ag s = function + CTL.True -> CTL.True + | CTL.False -> CTL.False + | x -> CTL.AG(CTL.FORWARD,s,x) + +let ctl_au s x y = + match (x,!exists) with + (CTL.True,Exists) -> CTL.EF(CTL.FORWARD,y) + | (CTL.True,Forall) -> CTL.AF(CTL.FORWARD,s,y) + | (CTL.True,ReverseForall) -> failwith "not supported" + | (_,Exists) -> CTL.EU(CTL.FORWARD,x,y) + | (_,Forall) -> CTL.AU(CTL.FORWARD,s,x,y) + | (_,ReverseForall) -> failwith "not supported" + +let ctl_anti_au s x y = (* only for ..., where the quantifier is changed *) + CTL.XX + (match (x,!exists) with + (CTL.True,Exists) -> CTL.AF(CTL.FORWARD,s,y) + | (CTL.True,Forall) -> CTL.EF(CTL.FORWARD,y) + | (CTL.True,ReverseForall) -> failwith "not supported" + | (_,Exists) -> CTL.AU(CTL.FORWARD,s,x,y) + | (_,Forall) -> CTL.EU(CTL.FORWARD,x,y) + | (_,ReverseForall) -> failwith "not supported") + +let ctl_uncheck = function + CTL.True -> CTL.True + | CTL.False -> CTL.False + | x -> CTL.Uncheck x + +let label_pred_maker = function + None -> CTL.True + | Some (label_var,used) -> + used := true; + CTL.Pred(Lib_engine.PrefixLabel(label_var),CTL.Control) + +let bclabel_pred_maker = function + None -> CTL.True + | Some (label_var,used) -> + used := true; + CTL.Pred(Lib_engine.BCLabel(label_var),CTL.Control) + +let predmaker guard pred label = + ctl_and (guard_to_strict guard) (CTL.Pred pred) (label_pred_maker label) + +let aftpred = predmaker false (Lib_engine.After, CTL.Control) +let retpred = predmaker false (Lib_engine.Return, CTL.Control) +let funpred = predmaker false (Lib_engine.FunHeader, CTL.Control) +let toppred = predmaker false (Lib_engine.Top, CTL.Control) +let exitpred = predmaker false (Lib_engine.ErrorExit, CTL.Control) +let endpred = predmaker false (Lib_engine.Exit, CTL.Control) +let gotopred = predmaker false (Lib_engine.Goto, CTL.Control) +let inlooppred = predmaker false (Lib_engine.InLoop, CTL.Control) +let truepred = predmaker false (Lib_engine.TrueBranch, CTL.Control) +let falsepred = predmaker false (Lib_engine.FalseBranch, CTL.Control) +let fallpred = predmaker false (Lib_engine.FallThrough, CTL.Control) + +let aftret label_var f = ctl_or (aftpred label_var) (exitpred label_var) + +let letctr = ref 0 +let get_let_ctr _ = + let cur = !letctr in + letctr := cur + 1; + Printf.sprintf "r%d" cur + +(* --------------------------------------------------------------------- *) +(* --------------------------------------------------------------------- *) +(* Eliminate OptStm *) + +(* for optional thing with nothing after, should check that the optional thing +never occurs. otherwise the matching stops before it occurs *) +let elim_opt = + let mcode x = x in + let donothing r k e = k e in + + let fvlist l = + List.fold_left Common.union_set [] (List.map Ast.get_fvs l) in + + let mfvlist l = + List.fold_left Common.union_set [] (List.map Ast.get_mfvs l) in + + let freshlist l = + List.fold_left Common.union_set [] (List.map Ast.get_fresh l) in + + let inheritedlist l = + List.fold_left Common.union_set [] (List.map Ast.get_inherited l) in + + let savedlist l = + List.fold_left Common.union_set [] (List.map Ast.get_saved l) in + + let varlists l = + (fvlist l, mfvlist l, freshlist l, inheritedlist l, savedlist l) in + + let rec dots_list unwrapped wrapped = + match (unwrapped,wrapped) with + ([],_) -> [] + + | (Ast.Dots(_,_,_,_)::Ast.OptStm(stm)::(Ast.Dots(_,_,_,_) as u)::urest, + d0::s::d1::rest) + | (Ast.Nest(_,_,_,_,_)::Ast.OptStm(stm)::(Ast.Dots(_,_,_,_) as u)::urest, + d0::s::d1::rest) -> + let l = Ast.get_line stm in + let new_rest1 = stm :: (dots_list (u::urest) (d1::rest)) in + let new_rest2 = dots_list urest rest in + let (fv_rest1,mfv_rest1,fresh_rest1,inherited_rest1,s1) = + varlists new_rest1 in + let (fv_rest2,mfv_rest2,fresh_rest2,inherited_rest2,s2) = + varlists new_rest2 in + [d0; + {(Ast.make_term + (Ast.Disj + [{(Ast.make_term(Ast.DOTS(new_rest1))) with + Ast.node_line = l; + Ast.free_vars = fv_rest1; + Ast.minus_free_vars = mfv_rest1; + Ast.fresh_vars = fresh_rest1; + Ast.inherited = inherited_rest1; + Ast.saved_witness = s1}; + {(Ast.make_term(Ast.DOTS(new_rest2))) with + Ast.node_line = l; + Ast.free_vars = fv_rest2; + Ast.minus_free_vars = mfv_rest2; + Ast.fresh_vars = fresh_rest2; + Ast.inherited = inherited_rest2; + Ast.saved_witness = s2}])) with + Ast.node_line = l; + Ast.free_vars = fv_rest1; + Ast.minus_free_vars = mfv_rest1; + Ast.fresh_vars = fresh_rest1; + Ast.inherited = inherited_rest1; + Ast.saved_witness = s1}] + + | (Ast.OptStm(stm)::urest,_::rest) -> + let l = Ast.get_line stm in + let new_rest1 = dots_list urest rest in + let new_rest2 = stm::new_rest1 in + let (fv_rest1,mfv_rest1,fresh_rest1,inherited_rest1,s1) = + varlists new_rest1 in + let (fv_rest2,mfv_rest2,fresh_rest2,inherited_rest2,s2) = + varlists new_rest2 in + [{(Ast.make_term + (Ast.Disj + [{(Ast.make_term(Ast.DOTS(new_rest2))) with + Ast.node_line = l; + Ast.free_vars = fv_rest2; + Ast.minus_free_vars = mfv_rest2; + Ast.fresh_vars = fresh_rest2; + Ast.inherited = inherited_rest2; + Ast.saved_witness = s2}; + {(Ast.make_term(Ast.DOTS(new_rest1))) with + Ast.node_line = l; + Ast.free_vars = fv_rest1; + Ast.minus_free_vars = mfv_rest1; + Ast.fresh_vars = fresh_rest1; + Ast.inherited = inherited_rest1; + Ast.saved_witness = s1}])) with + Ast.node_line = l; + Ast.free_vars = fv_rest2; + Ast.minus_free_vars = mfv_rest2; + Ast.fresh_vars = fresh_rest2; + Ast.inherited = inherited_rest2; + Ast.saved_witness = s2}] + + | ([Ast.Dots(_,_,_,_);Ast.OptStm(stm)],[d1;_]) -> + let l = Ast.get_line stm in + let fv_stm = Ast.get_fvs stm in + let mfv_stm = Ast.get_mfvs stm in + let fresh_stm = Ast.get_fresh stm in + let inh_stm = Ast.get_inherited stm in + let saved_stm = Ast.get_saved stm in + let fv_d1 = Ast.get_fvs d1 in + let mfv_d1 = Ast.get_mfvs d1 in + let fresh_d1 = Ast.get_fresh d1 in + let inh_d1 = Ast.get_inherited d1 in + let saved_d1 = Ast.get_saved d1 in + let fv_both = Common.union_set fv_stm fv_d1 in + let mfv_both = Common.union_set mfv_stm mfv_d1 in + let fresh_both = Common.union_set fresh_stm fresh_d1 in + let inh_both = Common.union_set inh_stm inh_d1 in + let saved_both = Common.union_set saved_stm saved_d1 in + [d1; + {(Ast.make_term + (Ast.Disj + [{(Ast.make_term(Ast.DOTS([stm]))) with + Ast.node_line = l; + Ast.free_vars = fv_stm; + Ast.minus_free_vars = mfv_stm; + Ast.fresh_vars = fresh_stm; + Ast.inherited = inh_stm; + Ast.saved_witness = saved_stm}; + {(Ast.make_term(Ast.DOTS([d1]))) with + Ast.node_line = l; + Ast.free_vars = fv_d1; + Ast.minus_free_vars = mfv_d1; + Ast.fresh_vars = fresh_d1; + Ast.inherited = inh_d1; + Ast.saved_witness = saved_d1}])) with + Ast.node_line = l; + Ast.free_vars = fv_both; + Ast.minus_free_vars = mfv_both; + Ast.fresh_vars = fresh_both; + Ast.inherited = inh_both; + Ast.saved_witness = saved_both}] + + | ([Ast.Nest(_,_,_,_,_);Ast.OptStm(stm)],[d1;_]) -> + let l = Ast.get_line stm in + let rw = Ast.rewrap stm in + let rwd = Ast.rewrap stm in + let dots = Ast.Dots(Ast.make_mcode "...",[],[],[]) in + [d1;rw(Ast.Disj + [rwd(Ast.DOTS([stm])); + {(Ast.make_term(Ast.DOTS([rw dots]))) + with Ast.node_line = l}])] + + | (_::urest,stm::rest) -> stm :: (dots_list urest rest) + | _ -> failwith "not possible" in + + let stmtdotsfn r k d = + let d = k d in + Ast.rewrap d + (match Ast.unwrap d with + Ast.DOTS(l) -> Ast.DOTS(dots_list (List.map Ast.unwrap l) l) + | Ast.CIRCLES(l) -> failwith "elimopt: not supported" + | Ast.STARS(l) -> failwith "elimopt: not supported") in + + V.rebuilder + mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode + mcode + donothing donothing stmtdotsfn donothing + donothing donothing donothing donothing donothing donothing donothing + donothing donothing donothing donothing donothing + +(* --------------------------------------------------------------------- *) +(* after management *) +(* We need Guard for the following case: +<... + a + <... + b + ...> +...> +foo(); + +Here the inner <... b ...> should not go past foo. But foo is not the +"after" of the body of the outer nest, because we don't want to search for +it in the case where the body of the outer nest ends in something other +than dots or a nest. *) + +(* what is the difference between tail and end??? *) + +type after = After of formula | Guard of formula | Tail | End | VeryEnd + +let a2n = function After x -> Guard x | a -> a + +let print_ctl x = + let pp_pred (x,_) = Pretty_print_engine.pp_predicate x in + let pp_meta (_,x) = Common.pp x in + Pretty_print_ctl.pp_ctl (pp_pred,pp_meta) false x; + Format.print_newline() + +let print_after = function + After ctl -> Printf.printf "After:\n"; print_ctl ctl + | Guard ctl -> Printf.printf "Guard:\n"; print_ctl ctl + | Tail -> Printf.printf "Tail\n" + | VeryEnd -> Printf.printf "Very End\n" + | End -> Printf.printf "End\n" + +(* --------------------------------------------------------------------- *) +(* Top-level code *) + +let fresh_var _ = string2var "_v" +let fresh_pos _ = string2var "_pos" (* must be a constant *) + +let fresh_metavar _ = "_S" + +(* fvinfo is going to end up being from the whole associated statement. + it would be better if it were just the free variables in d, but free_vars.ml + doesn't keep track of free variables on + code *) +let make_meta_rule_elem d fvinfo = + let nm = fresh_metavar() in + Ast.make_meta_rule_elem nm d fvinfo + +let get_unquantified quantified vars = + List.filter (function x -> not (List.mem x quantified)) vars + +let make_seq guard l = + let s = guard_to_strict guard in + foldr1 (function rest -> function cur -> ctl_and s cur (ctl_ax s rest)) l + +let make_seq_after2 guard first rest = + let s = guard_to_strict guard in + match rest with + After rest -> ctl_and s first (ctl_ax s (ctl_ax s rest)) + | _ -> first + +let make_seq_after guard first rest = + match rest with + After rest -> make_seq guard [first;rest] + | _ -> first + +let opt_and guard first rest = + let s = guard_to_strict guard in + match first with + None -> rest + | Some first -> ctl_and s first rest + +let and_after guard first rest = + let s = guard_to_strict guard in + match rest with After rest -> ctl_and s first rest | _ -> first + +let contains_modif = + let bind x y = x or y in + let option_default = false in + let mcode r (_,_,kind,metapos) = + let modif = + match kind with + Ast.MINUS(_,_) -> true + | Ast.PLUS -> failwith "not possible" + | Ast.CONTEXT(_,info) -> not (info = Ast.NOTHING) in + let pos = + match metapos with + Ast.MetaPos(_,_,_,_,_) -> true + | Ast.NoMetaPos -> false in + modif or pos in + let do_nothing r k e = k e in + let rule_elem r k re = + let res = k re in + match Ast.unwrap re with + Ast.FunHeader(bef,_,fninfo,name,lp,params,rp) -> + bind (mcode r ((),(),bef,Ast.NoMetaPos)) res + | Ast.Decl(bef,_,decl) -> bind (mcode r ((),(),bef,Ast.NoMetaPos)) res + | _ -> res in + let recursor = + V.combiner bind option_default + mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode + mcode + do_nothing do_nothing do_nothing do_nothing + do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing + do_nothing rule_elem do_nothing do_nothing do_nothing do_nothing in + recursor.V.combiner_rule_elem + +(* code is not a DisjRuleElem *) +let make_match label guard code = + let v = fresh_var() in + let matcher = Lib_engine.Match(code) in + if contains_modif code && not guard + then CTL.Exists(true,v,predmaker guard (matcher,CTL.Modif v) label) + else + let iso_info = !Flag.track_iso_usage && not (Ast.get_isos code = []) in + (match (iso_info,!onlyModif,guard, + intersect !used_after (Ast.get_fvs code)) with + (false,true,_,[]) | (_,_,true,_) -> + predmaker guard (matcher,CTL.Control) label + | _ -> CTL.Exists(true,v,predmaker guard (matcher,CTL.UnModif v) label)) + +let make_raw_match label guard code = + predmaker guard (Lib_engine.Match(code),CTL.Control) label + +let rec seq_fvs quantified = function + [] -> [] + | fv1::fvs -> + let t1fvs = get_unquantified quantified fv1 in + let termfvs = + List.fold_left Common.union_set [] + (List.map (get_unquantified quantified) fvs) in + let bothfvs = Common.inter_set t1fvs termfvs in + let t1onlyfvs = Common.minus_set t1fvs bothfvs in + let new_quantified = Common.union_set bothfvs quantified in + (t1onlyfvs,bothfvs)::(seq_fvs new_quantified fvs) + +let quantify guard = + List.fold_right + (function cur -> + function code -> CTL.Exists (not guard && List.mem cur !saved,cur,code)) + +let non_saved_quantify = + List.fold_right + (function cur -> function code -> CTL.Exists (false,cur,code)) + +let intersectll lst nested_list = + List.filter (function x -> List.exists (List.mem x) nested_list) lst + +(* --------------------------------------------------------------------- *) +(* Count depth of braces. The translation of a closed brace appears deeply +nested within the translation of the sequence term, so the name of the +paren var has to take into account the names of the nested braces. On the +other hand the close brace does not escape, so we don't have to take into +account other paren variable names. *) + +(* called repetitively, which is inefficient, but less trouble than adding a +new field to Seq and FunDecl *) +let count_nested_braces s = + let bind x y = max x y in + let option_default = 0 in + let stmt_count r k s = + match Ast.unwrap s with + Ast.Seq(_,_,_,_) | Ast.FunDecl(_,_,_,_,_) -> (k s) + 1 + | _ -> k s in + let donothing r k e = k e in + let mcode r x = 0 in + let recursor = V.combiner bind option_default + mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode + mcode + donothing donothing donothing donothing + donothing donothing donothing donothing donothing donothing + donothing donothing stmt_count donothing donothing donothing in + let res = string_of_int (recursor.V.combiner_statement s) in + string2var ("p"^res) + +let labelctr = ref 0 +let get_label_ctr _ = + let cur = !labelctr in + labelctr := cur + 1; + string2var (Printf.sprintf "l%d" cur) + +(* --------------------------------------------------------------------- *) +(* annotate dots with before and after neighbors *) + +let print_bef_aft = function + Ast.WParen (re,n) -> + Printf.printf "bef/aft\n"; + Pretty_print_cocci.rule_elem "" re; + Format.print_newline() + | Ast.Other s -> + Printf.printf "bef/aft\n"; + Pretty_print_cocci.statement "" s; + Format.print_newline() + | Ast.Other_dots d -> + Printf.printf "bef/aft\n"; + Pretty_print_cocci.statement_dots d; + Format.print_newline() + +(* [] can only occur if we are in a disj, where it comes from a ? In that +case, we want to use a, which accumulates all of the previous patterns in +their entirety. *) +let rec get_before_elem sl a = + match Ast.unwrap sl with + Ast.DOTS(x) -> + let rec loop sl a = + match sl with + [] -> ([],Common.Right a) + | [e] -> + let (e,ea) = get_before_e e a in + ([e],Common.Left ea) + | e::sl -> + let (e,ea) = get_before_e e a in + let (sl,sla) = loop sl ea in + (e::sl,sla) in + let (l,a) = loop x a in + (Ast.rewrap sl (Ast.DOTS(l)),a) + | Ast.CIRCLES(x) -> failwith "not supported" + | Ast.STARS(x) -> failwith "not supported" + +and get_before sl a = + match get_before_elem sl a with + (term,Common.Left x) -> (term,x) + | (term,Common.Right x) -> (term,x) + +and get_before_whencode wc = + List.map + (function + Ast.WhenNot w -> let (w,_) = get_before w [] in Ast.WhenNot w + | Ast.WhenAlways w -> let (w,_) = get_before_e w [] in Ast.WhenAlways w + | Ast.WhenModifier(x) -> Ast.WhenModifier(x) + | Ast.WhenNotTrue w -> Ast.WhenNotTrue w + | Ast.WhenNotFalse w -> Ast.WhenNotFalse w) + wc + +and get_before_e s a = + match Ast.unwrap s with + Ast.Dots(d,w,_,aft) -> + (Ast.rewrap s (Ast.Dots(d,get_before_whencode w,a,aft)),a) + | Ast.Nest(stmt_dots,w,multi,_,aft) -> + let w = get_before_whencode w in + let (sd,_) = get_before stmt_dots a in + let a = + List.filter + (function + Ast.Other a -> + let unifies = + Unify_ast.unify_statement_dots + (Ast.rewrap s (Ast.DOTS([a]))) stmt_dots in + (match unifies with + Unify_ast.MAYBE -> false + | _ -> true) + | Ast.Other_dots a -> + let unifies = Unify_ast.unify_statement_dots a stmt_dots in + (match unifies with + Unify_ast.MAYBE -> false + | _ -> true) + | _ -> true) + a in + (Ast.rewrap s (Ast.Nest(sd,w,multi,a,aft)),[Ast.Other_dots stmt_dots]) + | Ast.Disj(stmt_dots_list) -> + let (dsl,dsla) = + List.split (List.map (function e -> get_before e a) stmt_dots_list) in + (Ast.rewrap s (Ast.Disj(dsl)),List.fold_left Common.union_set [] dsla) + | Ast.Atomic(ast) -> + (match Ast.unwrap ast with + Ast.MetaStmt(_,_,_,_) -> (s,[]) + | _ -> (s,[Ast.Other s])) + | Ast.Seq(lbrace,decls,body,rbrace) -> + let index = count_nested_braces s in + let (de,dea) = get_before decls [Ast.WParen(lbrace,index)] in + let (bd,_) = get_before body dea in + (Ast.rewrap s (Ast.Seq(lbrace,de,bd,rbrace)), + [Ast.WParen(rbrace,index)]) + | Ast.Define(header,body) -> + let (body,_) = get_before body [] in + (Ast.rewrap s (Ast.Define(header,body)), [Ast.Other s]) + | Ast.IfThen(ifheader,branch,aft) -> + let (br,_) = get_before_e branch [] in + (Ast.rewrap s (Ast.IfThen(ifheader,br,aft)), [Ast.Other s]) + | Ast.IfThenElse(ifheader,branch1,els,branch2,aft) -> + let (br1,_) = get_before_e branch1 [] in + let (br2,_) = get_before_e branch2 [] in + (Ast.rewrap s (Ast.IfThenElse(ifheader,br1,els,br2,aft)),[Ast.Other s]) + | Ast.While(header,body,aft) -> + let (bd,_) = get_before_e body [] in + (Ast.rewrap s (Ast.While(header,bd,aft)),[Ast.Other s]) + | Ast.For(header,body,aft) -> + let (bd,_) = get_before_e body [] in + (Ast.rewrap s (Ast.For(header,bd,aft)),[Ast.Other s]) + | Ast.Do(header,body,tail) -> + let (bd,_) = get_before_e body [] in + (Ast.rewrap s (Ast.Do(header,bd,tail)),[Ast.Other s]) + | Ast.Iterator(header,body,aft) -> + let (bd,_) = get_before_e body [] in + (Ast.rewrap s (Ast.Iterator(header,bd,aft)),[Ast.Other s]) + | Ast.Switch(header,lb,cases,rb) -> + let cases = + List.map + (function case_line -> + match Ast.unwrap case_line with + Ast.CaseLine(header,body) -> + let (body,_) = get_before body [] in + Ast.rewrap case_line (Ast.CaseLine(header,body)) + | Ast.OptCase(case_line) -> failwith "not supported") + cases in + (Ast.rewrap s (Ast.Switch(header,lb,cases,rb)),[Ast.Other s]) + | Ast.FunDecl(header,lbrace,decls,body,rbrace) -> + let (de,dea) = get_before decls [] in + let (bd,_) = get_before body dea in + (Ast.rewrap s (Ast.FunDecl(header,lbrace,de,bd,rbrace)),[]) + | _ -> + Pretty_print_cocci.statement "" s; Format.print_newline(); + failwith "get_before_e: not supported" + +let rec get_after sl a = + match Ast.unwrap sl with + Ast.DOTS(x) -> + let rec loop sl = + match sl with + [] -> ([],a) + | e::sl -> + let (sl,sla) = loop sl in + let (e,ea) = get_after_e e sla in + (e::sl,ea) in + let (l,a) = loop x in + (Ast.rewrap sl (Ast.DOTS(l)),a) + | Ast.CIRCLES(x) -> failwith "not supported" + | Ast.STARS(x) -> failwith "not supported" + +and get_after_whencode a wc = + List.map + (function + Ast.WhenNot w -> let (w,_) = get_after w a (*?*) in Ast.WhenNot w + | Ast.WhenAlways w -> let (w,_) = get_after_e w a in Ast.WhenAlways w + | Ast.WhenModifier(x) -> Ast.WhenModifier(x) + | Ast.WhenNotTrue w -> Ast.WhenNotTrue w + | Ast.WhenNotFalse w -> Ast.WhenNotFalse w) + wc + +and get_after_e s a = + match Ast.unwrap s with + Ast.Dots(d,w,bef,_) -> + (Ast.rewrap s (Ast.Dots(d,get_after_whencode a w,bef,a)),a) + | Ast.Nest(stmt_dots,w,multi,bef,_) -> + let w = get_after_whencode a w in + let (sd,_) = get_after stmt_dots a in + let a = + List.filter + (function + Ast.Other a -> + let unifies = + Unify_ast.unify_statement_dots + (Ast.rewrap s (Ast.DOTS([a]))) stmt_dots in + (match unifies with + Unify_ast.MAYBE -> false + | _ -> true) + | Ast.Other_dots a -> + let unifies = Unify_ast.unify_statement_dots a stmt_dots in + (match unifies with + Unify_ast.MAYBE -> false + | _ -> true) + | _ -> true) + a in + (Ast.rewrap s (Ast.Nest(sd,w,multi,bef,a)),[Ast.Other_dots stmt_dots]) + | Ast.Disj(stmt_dots_list) -> + let (dsl,dsla) = + List.split (List.map (function e -> get_after e a) stmt_dots_list) in + (Ast.rewrap s (Ast.Disj(dsl)),List.fold_left Common.union_set [] dsla) + | Ast.Atomic(ast) -> + (match Ast.unwrap ast with + Ast.MetaStmt(nm,keep,Ast.SequencibleAfterDots _,i) -> + (* check "after" information for metavar optimization *) + (* if the error is not desired, could just return [], then + the optimization (check for EF) won't take place *) + List.iter + (function + Ast.Other x -> + (match Ast.unwrap x with + Ast.Dots(_,_,_,_) | Ast.Nest(_,_,_,_,_) -> + failwith + "dots/nest not allowed before and after stmt metavar" + | _ -> ()) + | Ast.Other_dots x -> + (match Ast.undots x with + x::_ -> + (match Ast.unwrap x with + Ast.Dots(_,_,_,_) | Ast.Nest(_,_,_,_,_) -> + failwith + ("dots/nest not allowed before and after stmt "^ + "metavar") + | _ -> ()) + | _ -> ()) + | _ -> ()) + a; + (Ast.rewrap s + (Ast.Atomic + (Ast.rewrap s + (Ast.MetaStmt(nm,keep,Ast.SequencibleAfterDots a,i)))),[]) + | Ast.MetaStmt(_,_,_,_) -> (s,[]) + | _ -> (s,[Ast.Other s])) + | Ast.Seq(lbrace,decls,body,rbrace) -> + let index = count_nested_braces s in + let (bd,bda) = get_after body [Ast.WParen(rbrace,index)] in + let (de,_) = get_after decls bda in + (Ast.rewrap s (Ast.Seq(lbrace,de,bd,rbrace)), + [Ast.WParen(lbrace,index)]) + | Ast.Define(header,body) -> + let (body,_) = get_after body a in + (Ast.rewrap s (Ast.Define(header,body)), [Ast.Other s]) + | Ast.IfThen(ifheader,branch,aft) -> + let (br,_) = get_after_e branch a in + (Ast.rewrap s (Ast.IfThen(ifheader,br,aft)),[Ast.Other s]) + | Ast.IfThenElse(ifheader,branch1,els,branch2,aft) -> + let (br1,_) = get_after_e branch1 a in + let (br2,_) = get_after_e branch2 a in + (Ast.rewrap s (Ast.IfThenElse(ifheader,br1,els,br2,aft)),[Ast.Other s]) + | Ast.While(header,body,aft) -> + let (bd,_) = get_after_e body a in + (Ast.rewrap s (Ast.While(header,bd,aft)),[Ast.Other s]) + | Ast.For(header,body,aft) -> + let (bd,_) = get_after_e body a in + (Ast.rewrap s (Ast.For(header,bd,aft)),[Ast.Other s]) + | Ast.Do(header,body,tail) -> + let (bd,_) = get_after_e body a in + (Ast.rewrap s (Ast.Do(header,bd,tail)),[Ast.Other s]) + | Ast.Iterator(header,body,aft) -> + let (bd,_) = get_after_e body a in + (Ast.rewrap s (Ast.Iterator(header,bd,aft)),[Ast.Other s]) + | Ast.Switch(header,lb,cases,rb) -> + let cases = + List.map + (function case_line -> + match Ast.unwrap case_line with + Ast.CaseLine(header,body) -> + let (body,_) = get_after body [] in + Ast.rewrap case_line (Ast.CaseLine(header,body)) + | Ast.OptCase(case_line) -> failwith "not supported") + cases in + (Ast.rewrap s (Ast.Switch(header,lb,cases,rb)),[Ast.Other s]) + | Ast.FunDecl(header,lbrace,decls,body,rbrace) -> + let (bd,bda) = get_after body [] in + let (de,_) = get_after decls bda in + (Ast.rewrap s (Ast.FunDecl(header,lbrace,de,bd,rbrace)),[]) + | _ -> failwith "get_after_e: not supported" + +let preprocess_dots sl = + let (sl,_) = get_before sl [] in + let (sl,_) = get_after sl [] in + sl + +let preprocess_dots_e sl = + let (sl,_) = get_before_e sl [] in + let (sl,_) = get_after_e sl [] in + sl + +(* --------------------------------------------------------------------- *) +(* various return_related things *) + +let rec ends_in_return stmt_list = + match Ast.unwrap stmt_list with + Ast.DOTS(x) -> + (match List.rev x with + x::_ -> + (match Ast.unwrap x with + Ast.Atomic(x) -> + let rec loop x = + match Ast.unwrap x with + Ast.Return(_,_) | Ast.ReturnExpr(_,_,_) -> true + | Ast.DisjRuleElem((_::_) as l) -> List.for_all loop l + | _ -> false in + loop x + | Ast.Disj(disjs) -> List.for_all ends_in_return disjs + | _ -> false) + | _ -> false) + | Ast.CIRCLES(x) -> failwith "not supported" + | Ast.STARS(x) -> failwith "not supported" + +(* --------------------------------------------------------------------- *) +(* expressions *) + +let exptymatch l make_match make_guard_match = + let pos = fresh_pos() in + let matches_guard_matches = + List.map + (function x -> + let pos = Ast.make_mcode pos in + (make_match (Ast.set_pos x (Some pos)), + make_guard_match (Ast.set_pos x (Some pos)))) + l in + let (matches,guard_matches) = List.split matches_guard_matches in + let rec suffixes = function + [] -> [] + | x::xs -> xs::(suffixes xs) in + let prefixes = List.rev (suffixes (List.rev guard_matches)) in + let info = (* not null *) + List.map2 + (function matcher -> + function negates -> + CTL.Exists + (false,pos, + ctl_and CTL.NONSTRICT matcher + (ctl_not + (ctl_uncheck (List.fold_left ctl_or_fl CTL.False negates))))) + matches prefixes in + CTL.InnerAnd(List.fold_left ctl_or_fl CTL.False (List.rev info)) + +(* code might be a DisjRuleElem, in which case we break it apart + code might contain an Exp or Ty + this one pushes the quantifier inwards *) +let do_re_matches label guard res quantified minus_quantified = + let make_guard_match x = + let stmt_fvs = Ast.get_mfvs x in + let fvs = get_unquantified minus_quantified stmt_fvs in + non_saved_quantify fvs (make_match None true x) in + let make_match x = + let stmt_fvs = Ast.get_fvs x in + let fvs = get_unquantified quantified stmt_fvs in + quantify guard fvs (make_match None guard x) in + ctl_and CTL.NONSTRICT (label_pred_maker label) + (match List.map Ast.unwrap res with + [] -> failwith "unexpected empty disj" + | Ast.Exp(e)::rest -> exptymatch res make_match make_guard_match + | Ast.Ty(t)::rest -> exptymatch res make_match make_guard_match + | all -> + if List.exists (function Ast.Exp(_) | Ast.Ty(_) -> true | _ -> false) + all + then failwith "unexpected exp or ty"; + List.fold_left ctl_seqor CTL.False + (List.rev (List.map make_match res))) + +(* code might be a DisjRuleElem, in which case we break it apart + code doesn't contain an Exp or Ty + this one is for use when it is not practical to push the quantifier inwards + *) +let header_match label guard code : ('a, Ast.meta_name, 'b) CTL.generic_ctl = + match Ast.unwrap code with + Ast.DisjRuleElem(res) -> + let make_match = make_match None guard in + let orop = if guard then ctl_or else ctl_seqor in + ctl_and CTL.NONSTRICT (label_pred_maker label) + (List.fold_left orop CTL.False (List.map make_match res)) + | _ -> make_match label guard code + +(* --------------------------------------------------------------------- *) +(* control structures *) + +let end_control_structure fvs header body after_pred + after_checks no_after_checks (afvs,afresh,ainh,aft) after label guard = + (* aft indicates what is added after the whole if, which has to be added + to the endif node *) + let (aft_needed,after_branch) = + match aft with + Ast.CONTEXT(_,Ast.NOTHING) -> + (false,make_seq_after2 guard after_pred after) + | _ -> + let match_endif = + make_match label guard + (make_meta_rule_elem aft (afvs,afresh,ainh)) in + (true, + make_seq_after guard after_pred + (After(make_seq_after guard match_endif after))) in + let body = body after_branch in + let s = guard_to_strict guard in + (* the code *) + quantify guard fvs + (ctl_and s header + (opt_and guard + (match (after,aft_needed) with + (After _,_) (* pattern doesn't end here *) + | (_,true) (* + code added after *) -> after_checks + | _ -> no_after_checks) + (ctl_ax_absolute s body))) + +let ifthen ifheader branch ((afvs,_,_,_) as aft) after + quantified minus_quantified label llabel slabel recurse make_match guard = +(* "if (test) thn" becomes: + if(test) & AX((TrueBranch & AX thn) v FallThrough v After) + + "if (test) thn; after" becomes: + if(test) & AX((TrueBranch & AX thn) v FallThrough v (After & AXAX after)) + & EX After +*) + (* free variables *) + let (efvs,bfvs) = + match seq_fvs quantified + [Ast.get_fvs ifheader;Ast.get_fvs branch;afvs] with + [(efvs,b1fvs);(_,b2fvs);_] -> (efvs,Common.union_set b1fvs b2fvs) + | _ -> failwith "not possible" in + let new_quantified = Common.union_set bfvs quantified in + let (mefvs,mbfvs) = + match seq_fvs minus_quantified + [Ast.get_mfvs ifheader;Ast.get_mfvs branch;[]] with + [(efvs,b1fvs);(_,b2fvs);_] -> (efvs,Common.union_set b1fvs b2fvs) + | _ -> failwith "not possible" in + let new_mquantified = Common.union_set mbfvs minus_quantified in + (* if header *) + let if_header = quantify guard efvs (make_match ifheader) in + (* then branch and after *) + let lv = get_label_ctr() in + let used = ref false in + let true_branch = + make_seq guard + [truepred label; recurse branch Tail new_quantified new_mquantified + (Some (lv,used)) llabel slabel guard] in + let after_pred = aftpred label in + let or_cases after_branch = + ctl_or true_branch (ctl_or (fallpred label) after_branch) in + let (if_header,wrapper) = + if !used + then + let label_pred = CTL.Pred (Lib_engine.Label(lv),CTL.Control) in + (ctl_and CTL.NONSTRICT(*???*) if_header label_pred, + (function body -> quantify true [lv] body)) + else (if_header,function x -> x) in + wrapper + (end_control_structure bfvs if_header or_cases after_pred + (Some(ctl_ex after_pred)) None aft after label guard) + +let ifthenelse ifheader branch1 els branch2 ((afvs,_,_,_) as aft) after + quantified minus_quantified label llabel slabel recurse make_match guard = +(* "if (test) thn else els" becomes: + if(test) & AX((TrueBranch & AX thn) v + (FalseBranch & AX (else & AX els)) v After) + & EX FalseBranch + + "if (test) thn else els; after" becomes: + if(test) & AX((TrueBranch & AX thn) v + (FalseBranch & AX (else & AX els)) v + (After & AXAX after)) + & EX FalseBranch + & EX After +*) + (* free variables *) + let (e1fvs,b1fvs,s1fvs) = + match seq_fvs quantified + [Ast.get_fvs ifheader;Ast.get_fvs branch1;afvs] with + [(e1fvs,b1fvs);(s1fvs,b1afvs);_] -> + (e1fvs,Common.union_set b1fvs b1afvs,s1fvs) + | _ -> failwith "not possible" in + let (e2fvs,b2fvs,s2fvs) = + (* fvs on else? *) + match seq_fvs quantified + [Ast.get_fvs ifheader;Ast.get_fvs branch2;afvs] with + [(e2fvs,b2fvs);(s2fvs,b2afvs);_] -> + (e2fvs,Common.union_set b2fvs b2afvs,s2fvs) + | _ -> failwith "not possible" in + let bothfvs = union (union b1fvs b2fvs) (intersect s1fvs s2fvs) in + let exponlyfvs = intersect e1fvs e2fvs in + let new_quantified = union bothfvs quantified in + (* minus free variables *) + let (me1fvs,mb1fvs,ms1fvs) = + match seq_fvs minus_quantified + [Ast.get_mfvs ifheader;Ast.get_mfvs branch1;[]] with + [(e1fvs,b1fvs);(s1fvs,b1afvs);_] -> + (e1fvs,Common.union_set b1fvs b1afvs,s1fvs) + | _ -> failwith "not possible" in + let (me2fvs,mb2fvs,ms2fvs) = + (* fvs on else? *) + match seq_fvs minus_quantified + [Ast.get_mfvs ifheader;Ast.get_mfvs branch2;[]] with + [(e2fvs,b2fvs);(s2fvs,b2afvs);_] -> + (e2fvs,Common.union_set b2fvs b2afvs,s2fvs) + | _ -> failwith "not possible" in + let mbothfvs = union (union mb1fvs mb2fvs) (intersect ms1fvs ms2fvs) in + let new_mquantified = union mbothfvs minus_quantified in + (* if header *) + let if_header = quantify guard exponlyfvs (make_match ifheader) in + (* then and else branches *) + let lv = get_label_ctr() in + let used = ref false in + let true_branch = + make_seq guard + [truepred label; recurse branch1 Tail new_quantified new_mquantified + (Some (lv,used)) llabel slabel guard] in + let false_branch = + make_seq guard + [falsepred label; make_match els; + recurse branch2 Tail new_quantified new_mquantified + (Some (lv,used)) llabel slabel guard] in + let after_pred = aftpred label in + let or_cases after_branch = + ctl_or true_branch (ctl_or false_branch after_branch) in + let s = guard_to_strict guard in + let (if_header,wrapper) = + if !used + then + let label_pred = CTL.Pred (Lib_engine.Label(lv),CTL.Control) in + (ctl_and CTL.NONSTRICT(*???*) if_header label_pred, + (function body -> quantify true [lv] body)) + else (if_header,function x -> x) in + wrapper + (end_control_structure bothfvs if_header or_cases after_pred + (Some(ctl_and s (ctl_ex (falsepred label)) (ctl_ex after_pred))) + (Some(ctl_ex (falsepred label))) + aft after label guard) + +let forwhile header body ((afvs,_,_,_) as aft) after + quantified minus_quantified label recurse make_match guard = + let process _ = + (* the translation in this case is similar to that of an if with no else *) + (* free variables *) + let (efvs,bfvs) = + match seq_fvs quantified [Ast.get_fvs header;Ast.get_fvs body;afvs] with + [(efvs,b1fvs);(_,b2fvs);_] -> (efvs,Common.union_set b1fvs b2fvs) + | _ -> failwith "not possible" in + let new_quantified = Common.union_set bfvs quantified in + (* minus free variables *) + let (mefvs,mbfvs) = + match seq_fvs minus_quantified + [Ast.get_mfvs header;Ast.get_mfvs body;[]] with + [(efvs,b1fvs);(_,b2fvs);_] -> (efvs,Common.union_set b1fvs b2fvs) + | _ -> failwith "not possible" in + let new_mquantified = Common.union_set mbfvs minus_quantified in + (* loop header *) + let header = quantify guard efvs (make_match header) in + let lv = get_label_ctr() in + let used = ref false in + let body = + make_seq guard + [inlooppred label; + recurse body Tail new_quantified new_mquantified + (Some (lv,used)) (Some (lv,used)) None guard] in + let after_pred = fallpred label in + let or_cases after_branch = ctl_or body after_branch in + let (header,wrapper) = + if !used + then + let label_pred = CTL.Pred (Lib_engine.Label(lv),CTL.Control) in + (ctl_and CTL.NONSTRICT(*???*) header label_pred, + (function body -> quantify true [lv] body)) + else (header,function x -> x) in + wrapper + (end_control_structure bfvs header or_cases after_pred + (Some(ctl_ex after_pred)) None aft after label guard) in + match (Ast.unwrap body,aft) with + (Ast.Atomic(re),(_,_,_,Ast.CONTEXT(_,Ast.NOTHING))) -> + (match Ast.unwrap re with + Ast.MetaStmt((_,_,Ast.CONTEXT(_,Ast.NOTHING),_), + Type_cocci.Unitary,_,false) -> + let (efvs) = + match seq_fvs quantified [Ast.get_fvs header] with + [(efvs,_)] -> efvs + | _ -> failwith "not possible" in + quantify guard efvs (make_match header) + | _ -> process()) + | _ -> process() + +(* --------------------------------------------------------------------- *) +(* statement metavariables *) + +(* issue: an S metavariable that is not an if branch/loop body + should not match an if branch/loop body, so check that the labels + of the nodes before the first node matched by the S are different + from the label of the first node matched by the S *) +let sequencibility body label_pred process_bef_aft = function + Ast.Sequencible | Ast.SequencibleAfterDots [] -> + body + (function x -> + (ctl_and CTL.NONSTRICT (ctl_not (ctl_back_ax label_pred)) x)) + | Ast.SequencibleAfterDots l -> + (* S appears after some dots. l is the code that comes after the S. + want to search for that first, because S can match anything, while + the stuff after is probably more restricted *) + let afts = List.map process_bef_aft l in + let ors = foldl1 ctl_or afts in + ctl_and CTL.NONSTRICT + (ctl_ef (ctl_and CTL.NONSTRICT ors (ctl_back_ax label_pred))) + (body + (function x -> + ctl_and CTL.NONSTRICT (ctl_not (ctl_back_ax label_pred)) x)) + | Ast.NotSequencible -> body (function x -> x) + +let svar_context_with_add_after stmt s label quantified d ast + seqible after process_bef_aft guard fvinfo = + let label_var = (*fresh_label_var*) string2var "_lab" in + let label_pred = + CTL.Pred (Lib_engine.Label(label_var),CTL.Control) in + let prelabel_pred = + CTL.Pred (Lib_engine.PrefixLabel(label_var),CTL.Control) in + let matcher d = make_match None guard (make_meta_rule_elem d fvinfo) in + let full_metamatch = matcher d in + let first_metamatch = + matcher + (match d with + Ast.CONTEXT(pos,Ast.BEFOREAFTER(bef,_)) -> + Ast.CONTEXT(pos,Ast.BEFORE(bef)) + | Ast.CONTEXT(pos,_) -> Ast.CONTEXT(pos,Ast.NOTHING) + | Ast.MINUS(_,_) | Ast.PLUS -> failwith "not possible") in + let middle_metamatch = + matcher + (match d with + Ast.CONTEXT(pos,_) -> Ast.CONTEXT(pos,Ast.NOTHING) + | Ast.MINUS(_,_) | Ast.PLUS -> failwith "not possible") in + let last_metamatch = + matcher + (match d with + Ast.CONTEXT(pos,Ast.BEFOREAFTER(_,aft)) -> + Ast.CONTEXT(pos,Ast.AFTER(aft)) + | Ast.CONTEXT(_,_) -> d + | Ast.MINUS(_,_) | Ast.PLUS -> failwith "not possible") in + + let rest_nodes = + ctl_and CTL.NONSTRICT middle_metamatch prelabel_pred in + let left_or = (* the whole statement is one node *) + make_seq guard + [full_metamatch; and_after guard (ctl_not prelabel_pred) after] in + let right_or = (* the statement covers multiple nodes *) + make_seq guard + [first_metamatch; + ctl_au CTL.NONSTRICT + rest_nodes + (make_seq guard + [ctl_and CTL.NONSTRICT last_metamatch label_pred; + and_after guard + (ctl_not prelabel_pred) after])] in + let body f = + ctl_and CTL.NONSTRICT label_pred + (f (ctl_and CTL.NONSTRICT + (make_raw_match label false ast) (ctl_or left_or right_or))) in + let stmt_fvs = Ast.get_fvs stmt in + let fvs = get_unquantified quantified stmt_fvs in + quantify guard (label_var::fvs) + (sequencibility body label_pred process_bef_aft seqible) + +let svar_minus_or_no_add_after stmt s label quantified d ast + seqible after process_bef_aft guard fvinfo = + let label_var = (*fresh_label_var*) string2var "_lab" in + let label_pred = + CTL.Pred (Lib_engine.Label(label_var),CTL.Control) in + let prelabel_pred = + CTL.Pred (Lib_engine.PrefixLabel(label_var),CTL.Control) in + let matcher d = make_match None guard (make_meta_rule_elem d fvinfo) in + let pure_d = + (* don't have to put anything before the beginning, so don't have to + distinguish the first node. so don't have to bother about paths, + just use the label. label ensures that found nodes match up with + what they should because it is in the lhs of the andany. *) + match d with + Ast.MINUS(pos,[]) -> true + | Ast.CONTEXT(pos,Ast.NOTHING) -> true + | _ -> false in + let ender = + match (pure_d,after) with + (true,Tail) | (true,End) | (true,VeryEnd) -> + (* the label sharing makes it safe to use AndAny *) + CTL.HackForStmt(CTL.FORWARD,CTL.NONSTRICT, + ctl_and CTL.NONSTRICT label_pred + (make_raw_match label false ast), + ctl_and CTL.NONSTRICT (matcher d) prelabel_pred) + | _ -> + (* more safe but less efficient *) + let first_metamatch = matcher d in + let rest_metamatch = + matcher + (match d with + Ast.MINUS(pos,_) -> Ast.MINUS(pos,[]) + | Ast.CONTEXT(pos,_) -> Ast.CONTEXT(pos,Ast.NOTHING) + | Ast.PLUS -> failwith "not possible") in + let rest_nodes = ctl_and CTL.NONSTRICT rest_metamatch prelabel_pred in + let last_node = and_after guard (ctl_not prelabel_pred) after in + (ctl_and CTL.NONSTRICT (make_raw_match label false ast) + (make_seq guard + [first_metamatch; + ctl_au CTL.NONSTRICT rest_nodes last_node])) in + let body f = ctl_and CTL.NONSTRICT label_pred (f ender) in + let stmt_fvs = Ast.get_fvs stmt in + let fvs = get_unquantified quantified stmt_fvs in + quantify guard (label_var::fvs) + (sequencibility body label_pred process_bef_aft seqible) + +(* --------------------------------------------------------------------- *) +(* dots and nests *) + +let dots_au is_strict toend label s wrapcode x seq_after y quantifier = + let matchgoto = gotopred None in + let matchbreak = + make_match None false + (wrapcode + (Ast.Break(Ast.make_mcode "break",Ast.make_mcode ";"))) in + let matchcontinue = + make_match None false + (wrapcode + (Ast.Continue(Ast.make_mcode "continue",Ast.make_mcode ";"))) in + let stop_early = + if quantifier = Exists + then Common.Left(CTL.False) + else if toend + then Common.Left(CTL.Or(aftpred label,exitpred label)) + else if is_strict + then Common.Left(aftpred label) + else + Common.Right + (function v -> + let lv = get_label_ctr() in + let labelpred = CTL.Pred(Lib_engine.Label lv,CTL.Control) in + let preflabelpred = label_pred_maker (Some (lv,ref true)) in + ctl_or (aftpred label) + (quantify false [lv] + (ctl_and CTL.NONSTRICT + (ctl_and CTL.NONSTRICT (truepred label) labelpred) + (ctl_au CTL.NONSTRICT + (ctl_and CTL.NONSTRICT (ctl_not v) preflabelpred) + (ctl_and CTL.NONSTRICT preflabelpred + (ctl_or (retpred None) + (if !Flag_matcher.only_return_is_error_exit + then CTL.True + else + (ctl_or matchcontinue + (ctl_and CTL.NONSTRICT + (ctl_or matchgoto matchbreak) + (ctl_ag s (ctl_not seq_after))))))))))) in + let op = if quantifier = !exists then ctl_au else ctl_anti_au in + let v = get_let_ctr() in + op s x + (match stop_early with + Common.Left x -> ctl_or y x + | Common.Right stop_early -> + CTL.Let(v,y,ctl_or (CTL.Ref v) (stop_early (CTL.Ref v)))) + +let rec dots_and_nests plus nest whencodes bef aft dotcode after label + process_bef_aft statement_list statement guard quantified wrapcode = + let ctl_and_ns = ctl_and CTL.NONSTRICT in + (* proces bef_aft *) + let shortest l = + List.fold_left ctl_or_fl CTL.False (List.map process_bef_aft l) in + let bef_aft = (* to be negated *) + try + let _ = + List.find + (function Ast.WhenModifier(Ast.WhenAny) -> true | _ -> false) + whencodes in + CTL.False + with Not_found -> shortest (Common.union_set bef aft) in + let is_strict = + List.exists + (function Ast.WhenModifier(Ast.WhenStrict) -> true | _ -> false) + whencodes in + let check_quantifier quant other = + if List.exists + (function Ast.WhenModifier(x) -> x = quant | _ -> false) + whencodes + then + if List.exists + (function Ast.WhenModifier(x) -> x = other | _ -> false) + whencodes + then failwith "inconsistent annotation on dots" + else true + else false in + let quantifier = + if check_quantifier Ast.WhenExists Ast.WhenForall + then Exists + else + if check_quantifier Ast.WhenForall Ast.WhenExists + then Forall + else !exists in + (* the following is used when we find a goto, etc and consider accepting + without finding the rest of the pattern *) + let aft = shortest aft in + (* process whencode *) + let labelled = label_pred_maker label in + let whencodes arg = + let (poswhen,negwhen) = + List.fold_left + (function (poswhen,negwhen) -> + function + Ast.WhenNot whencodes -> + (poswhen,ctl_or (statement_list whencodes) negwhen) + | Ast.WhenAlways stm -> + (ctl_and CTL.NONSTRICT (statement stm) poswhen,negwhen) + | Ast.WhenModifier(_) -> (poswhen,negwhen) + | Ast.WhenNotTrue(e) -> + (poswhen, + ctl_or (whencond_true e label guard quantified) negwhen) + | Ast.WhenNotFalse(e) -> + (poswhen, + ctl_or (whencond_false e label guard quantified) negwhen)) + (CTL.True,bef_aft) (List.rev whencodes) in + let poswhen = ctl_and_ns arg poswhen in + let negwhen = +(* if !exists + then*) + (* add in After, because it's not part of the program *) + ctl_or (aftpred label) negwhen + (*else negwhen*) in + ctl_and_ns poswhen (ctl_not negwhen) in + (* process dot code, if any *) + let dotcode = + match (dotcode,guard) with + (None,_) | (_,true) -> CTL.True + | (Some dotcode,_) -> dotcode in + (* process nest code, if any *) + (* whencode goes in the negated part of the nest; if no nest, just goes + on the "true" in between code *) + let plus_var = if plus then get_label_ctr() else string2var "" in + let plus_var2 = if plus then get_label_ctr() else string2var "" in + let ornest = + match (nest,guard && not plus) with + (None,_) | (_,true) -> whencodes CTL.True + | (Some nest,false) -> + let v = get_let_ctr() in + let is_plus x = + if plus + then + (* the idea is that BindGood is sort of a witness; a witness to + having found the subterm in at least one place. If there is + not a witness, then there is a risk that it will get thrown + away, if it is merged with a node that has an empty + environment. See tests/nestplus. But this all seems + rather suspicious *) + CTL.And(CTL.NONSTRICT,x, + CTL.Exists(true,plus_var2, + CTL.Pred(Lib_engine.BindGood(plus_var), + CTL.Modif plus_var2))) + else x in + CTL.Let(v,nest, + CTL.Or(is_plus (CTL.Ref v), + whencodes (CTL.Not(ctl_uncheck (CTL.Ref v))))) in + let plus_modifier x = + if plus + then + CTL.Exists + (false,plus_var, + (CTL.And + (CTL.NONSTRICT,x, + CTL.Not(CTL.Pred(Lib_engine.BindBad(plus_var),CTL.Control))))) + else x in + + let ender = + match after with + After f -> f + | Guard f -> ctl_uncheck f + | VeryEnd -> + let exit = endpred label in + let errorexit = exitpred label in + ctl_or exit errorexit + (* not at all sure what the next two mean... *) + | End -> CTL.True + | Tail -> + (match label with + Some (lv,used) -> used := true; + ctl_or (CTL.Pred(Lib_engine.Label lv,CTL.Control)) + (ctl_back_ex (ctl_or (retpred label) (gotopred label))) + | None -> endpred label) + (* was the following, but not clear why sgrep should allow + incomplete patterns + let exit = endpred label in + let errorexit = exitpred label in + if !exists + then ctl_or exit errorexit (* end anywhere *) + else exit (* end at the real end of the function *) *) in + plus_modifier + (dots_au is_strict ((after = Tail) or (after = VeryEnd)) + label (guard_to_strict guard) wrapcode + (ctl_and_ns dotcode (ctl_and_ns ornest labelled)) + aft ender quantifier) + +and get_whencond_exps e = + match Ast.unwrap e with + Ast.Exp e -> [e] + | Ast.DisjRuleElem(res) -> + List.fold_left Common.union_set [] (List.map get_whencond_exps res) + | _ -> failwith "not possible" + +and make_whencond_headers e e1 label guard quantified = + let fvs = Ast.get_fvs e in + let header_pred h = + quantify guard (get_unquantified quantified fvs) + (make_match label guard h) in + let if_header e1 = + header_pred + (Ast.rewrap e + (Ast.IfHeader + (Ast.make_mcode "if", + Ast.make_mcode "(",e1,Ast.make_mcode ")"))) in + let while_header e1 = + header_pred + (Ast.rewrap e + (Ast.WhileHeader + (Ast.make_mcode "while", + Ast.make_mcode "(",e1,Ast.make_mcode ")"))) in + let for_header e1 = + header_pred + (Ast.rewrap e + (Ast.ForHeader + (Ast.make_mcode "for",Ast.make_mcode "(",None,Ast.make_mcode ";", + Some e1,Ast.make_mcode ";",None,Ast.make_mcode ")"))) in + let if_headers = + List.fold_left ctl_or CTL.False (List.map if_header e1) in + let while_headers = + List.fold_left ctl_or CTL.False (List.map while_header e1) in + let for_headers = + List.fold_left ctl_or CTL.False (List.map for_header e1) in + (if_headers, while_headers, for_headers) + +and whencond_true e label guard quantified = + let e1 = get_whencond_exps e in + let (if_headers, while_headers, for_headers) = + make_whencond_headers e e1 label guard quantified in + ctl_or + (ctl_and CTL.NONSTRICT (truepred label) (ctl_back_ex if_headers)) + (ctl_and CTL.NONSTRICT + (inlooppred label) (ctl_back_ex (ctl_or while_headers for_headers))) + +and whencond_false e label guard quantified = + let e1 = get_whencond_exps e in + let (if_headers, while_headers, for_headers) = + make_whencond_headers e e1 label guard quantified in + ctl_or (ctl_and CTL.NONSTRICT (falsepred label) (ctl_back_ex if_headers)) + (ctl_and CTL.NONSTRICT (fallpred label) + (ctl_or (ctl_back_ex if_headers) + (ctl_or (ctl_back_ex while_headers) (ctl_back_ex for_headers)))) + +(* --------------------------------------------------------------------- *) +(* the main translation loop *) + +let rec statement_list stmt_list after quantified minus_quantified + label llabel slabel dots_before guard = + let isdots x = + (* include Disj to be on the safe side *) + match Ast.unwrap x with + Ast.Dots _ | Ast.Nest _ | Ast.Disj _ -> true | _ -> false in + let compute_label l e db = if db or isdots e then l else None in + match Ast.unwrap stmt_list with + Ast.DOTS(x) -> + let rec loop quantified minus_quantified dots_before label llabel slabel + = function + ([],_,_) -> (match after with After f -> f | _ -> CTL.True) + | ([e],_,_) -> + statement e after quantified minus_quantified + (compute_label label e dots_before) + llabel slabel guard + | (e::sl,fv::fvs,mfv::mfvs) -> + let shared = intersectll fv fvs in + let unqshared = get_unquantified quantified shared in + let new_quantified = Common.union_set unqshared quantified in + let minus_shared = intersectll mfv mfvs in + let munqshared = + get_unquantified minus_quantified minus_shared in + let new_mquantified = + Common.union_set munqshared minus_quantified in + quantify guard unqshared + (statement e + (After + (let (label1,llabel1,slabel1) = + match Ast.unwrap e with + Ast.Atomic(re) -> + (match Ast.unwrap re with + Ast.Goto _ -> (None,None,None) + | _ -> (label,llabel,slabel)) + | _ -> (label,llabel,slabel) in + loop new_quantified new_mquantified (isdots e) + label1 llabel1 slabel1 + (sl,fvs,mfvs))) + new_quantified new_mquantified + (compute_label label e dots_before) llabel slabel guard) + | _ -> failwith "not possible" in + loop quantified minus_quantified dots_before + label llabel slabel + (x,List.map Ast.get_fvs x,List.map Ast.get_mfvs x) + | Ast.CIRCLES(x) -> failwith "not supported" + | Ast.STARS(x) -> failwith "not supported" + +(* llabel is the label of the enclosing loop and slabel is the label of the + enclosing switch *) +and statement stmt after quantified minus_quantified + label llabel slabel guard = + let ctl_au = ctl_au CTL.NONSTRICT in + let ctl_ax = ctl_ax CTL.NONSTRICT in + let ctl_and = ctl_and CTL.NONSTRICT in + let make_seq = make_seq guard in + let make_seq_after = make_seq_after guard in + let real_make_match = make_match in + let make_match = header_match label guard in + + let dots_done = ref false in (* hack for dots cases we can easily handle *) + + let term = + match Ast.unwrap stmt with + Ast.Atomic(ast) -> + (match Ast.unwrap ast with + (* the following optimisation is not a good idea, because when S + is alone, we would like it not to match a declaration. + this makes more matching for things like when (...) S, but perhaps + that matching is not so costly anyway *) + (*Ast.MetaStmt(_,Type_cocci.Unitary,_,false) when guard -> CTL.True*) + | Ast.MetaStmt((s,_,(Ast.CONTEXT(_,Ast.BEFOREAFTER(_,_)) as d),_), + keep,seqible,_) + | Ast.MetaStmt((s,_,(Ast.CONTEXT(_,Ast.AFTER(_)) as d),_), + keep,seqible,_)-> + svar_context_with_add_after stmt s label quantified d ast seqible + after + (process_bef_aft quantified minus_quantified + label llabel slabel true) + guard + (Ast.get_fvs stmt, Ast.get_fresh stmt, Ast.get_inherited stmt) + + | Ast.MetaStmt((s,_,d,_),keep,seqible,_) -> + svar_minus_or_no_add_after stmt s label quantified d ast seqible + after + (process_bef_aft quantified minus_quantified + label llabel slabel true) + guard + (Ast.get_fvs stmt, Ast.get_fresh stmt, Ast.get_inherited stmt) + + | _ -> + let term = + match Ast.unwrap ast with + Ast.DisjRuleElem(res) -> + do_re_matches label guard res quantified minus_quantified + | Ast.Exp(_) | Ast.Ty(_) -> + let stmt_fvs = Ast.get_fvs stmt in + let fvs = get_unquantified quantified stmt_fvs in + CTL.InnerAnd(quantify guard fvs (make_match ast)) + | _ -> + let stmt_fvs = Ast.get_fvs stmt in + let fvs = get_unquantified quantified stmt_fvs in + quantify guard fvs (make_match ast) in + match Ast.unwrap ast with + Ast.Break(brk,semi) -> + (match (llabel,slabel) with + (_,Some(lv,used)) -> (* use switch label if there is one *) + ctl_and term (bclabel_pred_maker slabel) + | _ -> ctl_and term (bclabel_pred_maker llabel)) + | Ast.Continue(brk,semi) -> ctl_and term (bclabel_pred_maker llabel) + | Ast.Return((_,info,retmc,pos),(_,_,semmc,_)) -> + (* discard pattern that comes after return *) + let normal_res = make_seq_after term after in + (* the following code tries to propagate the modifications on + return; to a close brace, in the case where the final return + is absent *) + let new_mc = + match (retmc,semmc) with + (Ast.MINUS(_,l1),Ast.MINUS(_,l2)) when !Flag.sgrep_mode2 -> + (* in sgrep mode, we can propagate the - *) + Some (Ast.MINUS(Ast.NoPos,l1@l2)) + | (Ast.MINUS(_,l1),Ast.MINUS(_,l2)) + | (Ast.CONTEXT(_,Ast.BEFORE(l1)), + Ast.CONTEXT(_,Ast.AFTER(l2))) -> + Some (Ast.CONTEXT(Ast.NoPos,Ast.BEFORE(l1@l2))) + | (Ast.CONTEXT(_,Ast.BEFORE(_)),Ast.CONTEXT(_,Ast.NOTHING)) + | (Ast.CONTEXT(_,Ast.NOTHING),Ast.CONTEXT(_,Ast.NOTHING)) -> + Some retmc + | (Ast.CONTEXT(_,Ast.NOTHING),Ast.CONTEXT(_,Ast.AFTER(l))) -> + Some (Ast.CONTEXT(Ast.NoPos,Ast.BEFORE(l))) + | _ -> None in + let ret = Ast.make_mcode "return" in + let edots = + Ast.rewrap ast (Ast.Edots(Ast.make_mcode "...",None)) in + let semi = Ast.make_mcode ";" in + let simple_return = + make_match(Ast.rewrap ast (Ast.Return(ret,semi))) in + let return_expr = + make_match(Ast.rewrap ast (Ast.ReturnExpr(ret,edots,semi))) in + (match new_mc with + Some new_mc -> + let exit = endpred None in + let mod_rbrace = + Ast.rewrap ast (Ast.SeqEnd (("}",info,new_mc,pos))) in + let stripped_rbrace = + Ast.rewrap ast (Ast.SeqEnd(Ast.make_mcode "}")) in + ctl_or normal_res + (ctl_and (make_match mod_rbrace) + (ctl_and + (ctl_back_ax + (ctl_not + (ctl_uncheck + (ctl_or simple_return return_expr)))) + (ctl_au + (make_match stripped_rbrace) + (* error exit not possible; it is in the middle + of code, so a return is needed *) + exit))) + | _ -> + (* some change in the middle of the return, so have to + find an actual return *) + normal_res) + | _ -> + (* should try to deal with the dots_bef_aft problem elsewhere, + but don't have the courage... *) + let term = + if guard + then term + else + do_between_dots stmt term End + quantified minus_quantified label llabel slabel guard in + dots_done := true; + make_seq_after term after) + | Ast.Seq(lbrace,decls,body,rbrace) -> + let (lbfvs,b1fvs,b2fvs,b3fvs,rbfvs) = + match + seq_fvs quantified + [Ast.get_fvs lbrace;Ast.get_fvs decls; + Ast.get_fvs body;Ast.get_fvs rbrace] + with + [(lbfvs,b1fvs);(_,b2fvs);(_,b3fvs);(rbfvs,_)] -> + (lbfvs,b1fvs,b2fvs,b3fvs,rbfvs) + | _ -> failwith "not possible" in + let (mlbfvs,mb1fvs,mb2fvs,mb3fvs,mrbfvs) = + match + seq_fvs minus_quantified + [Ast.get_mfvs lbrace;Ast.get_mfvs decls; + Ast.get_mfvs body;Ast.get_mfvs rbrace] + with + [(lbfvs,b1fvs);(_,b2fvs);(_,b3fvs);(rbfvs,_)] -> + (lbfvs,b1fvs,b2fvs,b3fvs,rbfvs) + | _ -> failwith "not possible" in + let pv = count_nested_braces stmt in + let lv = get_label_ctr() in + let paren_pred = CTL.Pred(Lib_engine.Paren pv,CTL.Control) in + let label_pred = CTL.Pred(Lib_engine.Label lv,CTL.Control) in + let start_brace = + ctl_and + (quantify guard lbfvs (make_match lbrace)) + (ctl_and paren_pred label_pred) in + let empty_rbrace = + match Ast.unwrap rbrace with + Ast.SeqEnd((data,info,_,pos)) -> + Ast.rewrap rbrace(Ast.SeqEnd(Ast.make_mcode data)) + | _ -> failwith "unexpected close brace" in + let end_brace = + (* label is not needed; paren_pred is enough *) + quantify guard rbfvs + (ctl_au (make_match empty_rbrace) + (ctl_and + (real_make_match None guard rbrace) + paren_pred)) in + let new_quantified2 = + Common.union_set b1fvs (Common.union_set b2fvs quantified) in + let new_quantified3 = Common.union_set b3fvs new_quantified2 in + let new_mquantified2 = + Common.union_set mb1fvs (Common.union_set mb2fvs minus_quantified) in + let new_mquantified3 = Common.union_set mb3fvs new_mquantified2 in + let pattern_as_given = + let new_quantified2 = Common.union_set [pv] new_quantified2 in + let new_quantified3 = Common.union_set [pv] new_quantified3 in + quantify true [pv;lv] + (quantify guard b1fvs + (make_seq + [start_brace; + quantify guard b2fvs + (statement_list decls + (After + (quantify guard b3fvs + (statement_list body + (After (make_seq_after end_brace after)) + new_quantified3 new_mquantified3 + (Some (lv,ref true)) (* label mostly useful *) + llabel slabel true guard))) + new_quantified2 new_mquantified2 + (Some (lv,ref true)) llabel slabel false guard)])) in + if ends_in_return body + then + (* matching error handling code *) + (* Cases: + 1. The pattern as given + 2. A goto, and then some close braces, and then the pattern as + given, but without the braces (only possible if there are no + decls, and open and close braces are unmodified) + 3. Part of the pattern as given, then a goto, and then the rest + of the pattern. For this case, we just check that all paths have + a goto within the current braces. checking for a goto at every + point in the pattern seems expensive and not worthwhile. *) + let pattern2 = + let body = preprocess_dots body in (* redo, to drop braces *) + make_seq + [gotopred label; + ctl_au + (make_match empty_rbrace) + (ctl_ax (* skip the destination label *) + (quantify guard b3fvs + (statement_list body End + new_quantified3 new_mquantified3 None llabel slabel + true guard)))] in + let pattern3 = + let new_quantified2 = Common.union_set [pv] new_quantified2 in + let new_quantified3 = Common.union_set [pv] new_quantified3 in + quantify true [pv;lv] + (quantify guard b1fvs + (make_seq + [start_brace; + ctl_and + (CTL.AU (* want AF even for sgrep *) + (CTL.FORWARD,CTL.STRICT, + CTL.Pred(Lib_engine.PrefixLabel(lv),CTL.Control), + ctl_and (* brace must be eventually after goto *) + (gotopred (Some (lv,ref true))) + (* want AF even for sgrep *) + (CTL.AF(CTL.FORWARD,CTL.STRICT,end_brace)))) + (quantify guard b2fvs + (statement_list decls + (After + (quantify guard b3fvs + (statement_list body Tail + (*After + (make_seq_after + nopv_end_brace after)*) + new_quantified3 new_mquantified3 + None llabel slabel true guard))) + new_quantified2 new_mquantified2 + (Some (lv,ref true)) + llabel slabel false guard))])) in + ctl_or pattern_as_given + (match Ast.unwrap decls with + Ast.DOTS([]) -> ctl_or pattern2 pattern3 + | Ast.DOTS(l) -> pattern3 + | _ -> failwith "circles and stars not supported") + else pattern_as_given + | Ast.IfThen(ifheader,branch,aft) -> + ifthen ifheader branch aft after quantified minus_quantified + label llabel slabel statement make_match guard + + | Ast.IfThenElse(ifheader,branch1,els,branch2,aft) -> + ifthenelse ifheader branch1 els branch2 aft after quantified + minus_quantified label llabel slabel statement make_match guard + + | Ast.While(header,body,aft) | Ast.For(header,body,aft) + | Ast.Iterator(header,body,aft) -> + forwhile header body aft after quantified minus_quantified + label statement make_match guard + + | Ast.Disj(stmt_dots_list) -> (* list shouldn't be empty *) + ctl_and + (label_pred_maker label) + (List.fold_left ctl_seqor CTL.False + (List.map + (function sl -> + statement_list sl after quantified minus_quantified label + llabel slabel true guard) + stmt_dots_list)) + + | Ast.Nest(stmt_dots,whencode,multi,bef,aft) -> + (* label in recursive call is None because label check is already + wrapped around the corresponding code *) + + let bfvs = + match seq_fvs quantified [Ast.get_wcfvs whencode;Ast.get_fvs stmt_dots] + with + [(wcfvs,bothfvs);(bdfvs,_)] -> bothfvs + | _ -> failwith "not possible" in + + (* no minus version because when code doesn't contain any minus code *) + let new_quantified = Common.union_set bfvs quantified in + + quantify guard bfvs + (let dots_pattern = + statement_list stmt_dots (a2n after) new_quantified minus_quantified + None llabel slabel true guard in + dots_and_nests multi + (Some dots_pattern) whencode bef aft None after label + (process_bef_aft new_quantified minus_quantified + None llabel slabel true) + (function x -> + statement_list x Tail new_quantified minus_quantified None + llabel slabel true true) + (function x -> + statement x Tail new_quantified minus_quantified None + llabel slabel true) + guard quantified + (function x -> Ast.set_fvs [] (Ast.rewrap stmt x))) + + | Ast.Dots((_,i,d,_),whencodes,bef,aft) -> + let dot_code = + match d with + Ast.MINUS(_,_) -> + (* no need for the fresh metavar, but ... is a bit wierd as a + variable name *) + Some(make_match (make_meta_rule_elem d ([],[],[]))) + | _ -> None in + dots_and_nests false None whencodes bef aft dot_code after label + (process_bef_aft quantified minus_quantified None llabel slabel true) + (function x -> + statement_list x Tail quantified minus_quantified + None llabel slabel true true) + (function x -> + statement x Tail quantified minus_quantified None llabel slabel true) + guard quantified + (function x -> Ast.set_fvs [] (Ast.rewrap stmt x)) + + | Ast.Switch(header,lb,cases,rb) -> + let rec intersect_all = function + [] -> [] + | [x] -> x + | x::xs -> intersect x (intersect_all xs) in + let rec union_all l = List.fold_left union [] l in + (* start normal variables *) + let header_fvs = Ast.get_fvs header in + let lb_fvs = Ast.get_fvs lb in + let case_fvs = List.map Ast.get_fvs cases in + let rb_fvs = Ast.get_fvs rb in + let (all_efvs,all_b1fvs,all_lbfvs,all_b2fvs, + all_casefvs,all_b3fvs,all_rbfvs) = + List.fold_left + (function (all_efvs,all_b1fvs,all_lbfvs,all_b2fvs, + all_casefvs,all_b3fvs,all_rbfvs) -> + function case_fvs -> + match seq_fvs quantified [header_fvs;lb_fvs;case_fvs;rb_fvs] with + [(efvs,b1fvs);(lbfvs,b2fvs);(casefvs,b3fvs);(rbfvs,_)] -> + (efvs::all_efvs,b1fvs::all_b1fvs,lbfvs::all_lbfvs, + b2fvs::all_b2fvs,casefvs::all_casefvs,b3fvs::all_b3fvs, + rbfvs::all_rbfvs) + | _ -> failwith "not possible") + ([],[],[],[],[],[],[]) case_fvs in + let (all_efvs,all_b1fvs,all_lbfvs,all_b2fvs, + all_casefvs,all_b3fvs,all_rbfvs) = + (List.rev all_efvs,List.rev all_b1fvs,List.rev all_lbfvs, + List.rev all_b2fvs,List.rev all_casefvs,List.rev all_b3fvs, + List.rev all_rbfvs) in + let exponlyfvs = intersect_all all_efvs in + let lbonlyfvs = intersect_all all_lbfvs in +(* don't do anything with right brace. Hope there is no + code on it *) +(* let rbonlyfvs = intersect_all all_rbfvs in*) + let b1fvs = union_all all_b1fvs in + let new1_quantified = union b1fvs quantified in + let b2fvs = union (union_all all_b1fvs) (intersect_all all_casefvs) in + let new2_quantified = union b2fvs new1_quantified in +(* let b3fvs = union_all all_b3fvs in*) + (* ------------------- start minus free variables *) + let header_mfvs = Ast.get_mfvs header in + let lb_mfvs = Ast.get_mfvs lb in + let case_mfvs = List.map Ast.get_mfvs cases in + let rb_mfvs = Ast.get_mfvs rb in + let (all_mefvs,all_mb1fvs,all_mlbfvs,all_mb2fvs, + all_mcasefvs,all_mb3fvs,all_mrbfvs) = + List.fold_left + (function (all_efvs,all_b1fvs,all_lbfvs,all_b2fvs, + all_casefvs,all_b3fvs,all_rbfvs) -> + function case_mfvs -> + match + seq_fvs quantified + [header_mfvs;lb_mfvs;case_mfvs;rb_mfvs] with + [(efvs,b1fvs);(lbfvs,b2fvs);(casefvs,b3fvs);(rbfvs,_)] -> + (efvs::all_efvs,b1fvs::all_b1fvs,lbfvs::all_lbfvs, + b2fvs::all_b2fvs,casefvs::all_casefvs,b3fvs::all_b3fvs, + rbfvs::all_rbfvs) + | _ -> failwith "not possible") + ([],[],[],[],[],[],[]) case_mfvs in + let (all_mefvs,all_mb1fvs,all_mlbfvs,all_mb2fvs, + all_mcasefvs,all_mb3fvs,all_mrbfvs) = + (List.rev all_mefvs,List.rev all_mb1fvs,List.rev all_mlbfvs, + List.rev all_mb2fvs,List.rev all_mcasefvs,List.rev all_mb3fvs, + List.rev all_mrbfvs) in +(* don't do anything with right brace. Hope there is no + code on it *) +(* let rbonlyfvs = intersect_all all_rbfvs in*) + let mb1fvs = union_all all_mb1fvs in + let new1_mquantified = union mb1fvs quantified in + let mb2fvs = union (union_all all_mb1fvs) (intersect_all all_mcasefvs) in + let new2_mquantified = union mb2fvs new1_mquantified in +(* let b3fvs = union_all all_b3fvs in*) + (* ------------------- end collection of free variables *) + let switch_header = quantify guard exponlyfvs (make_match header) in + let lb = quantify guard lbonlyfvs (make_match lb) in +(* let rb = quantify guard rbonlyfvs (make_match rb) in*) + let case_headers = + List.map + (function case_line -> + match Ast.unwrap case_line with + Ast.CaseLine(header,body) -> + let e1fvs = + match seq_fvs new2_quantified [Ast.get_fvs header] with + [(e1fvs,_)] -> e1fvs + | _ -> failwith "not possible" in + quantify guard e1fvs (real_make_match label true header) + | Ast.OptCase(case_line) -> failwith "not supported") + cases in + let no_header = + ctl_not (List.fold_left ctl_or_fl CTL.False case_headers) in + let lv = get_label_ctr() in + let used = ref false in + let case_code = + List.map + (function case_line -> + match Ast.unwrap case_line with + Ast.CaseLine(header,body) -> + let (e1fvs,b1fvs,s1fvs) = + let fvs = [Ast.get_fvs header;Ast.get_fvs body] in + match seq_fvs new2_quantified fvs with + [(e1fvs,b1fvs);(s1fvs,_)] -> (e1fvs,b1fvs,s1fvs) + | _ -> failwith "not possible" in + let (me1fvs,mb1fvs,ms1fvs) = + let fvs = [Ast.get_mfvs header;Ast.get_mfvs body] in + match seq_fvs new2_mquantified fvs with + [(e1fvs,b1fvs);(s1fvs,_)] -> (e1fvs,b1fvs,s1fvs) + | _ -> failwith "not possible" in + let case_header = + quantify guard e1fvs (make_match header) in + let new3_quantified = union b1fvs new2_quantified in + let new3_mquantified = union mb1fvs new2_mquantified in + let body = + statement_list body Tail + new3_quantified new3_mquantified label llabel + (Some (lv,used)) true(*?*) guard in + quantify guard b1fvs (make_seq [case_header; body]) + | Ast.OptCase(case_line) -> failwith "not supported") + cases in + let default_required = + if List.exists + (function case -> + match Ast.unwrap case with + Ast.CaseLine(header,_) -> + (match Ast.unwrap header with + Ast.Default(_,_) -> true + | _ -> false) + | _ -> false) + cases + then function x -> x + else function x -> ctl_or (fallpred label) x in + let after_pred = aftpred label in + let body after_branch = + ctl_or + (default_required + (quantify guard b2fvs + (make_seq + [ctl_and lb + (List.fold_left ctl_and CTL.True + (List.map ctl_ex case_headers)); + List.fold_left ctl_or_fl no_header case_code]))) + after_branch in + let aft = + (rb_fvs,Ast.get_fresh rb,Ast.get_inherited rb, + match Ast.unwrap rb with + Ast.SeqEnd(rb) -> Ast.get_mcodekind rb + | _ -> failwith "not possible") in + let (switch_header,wrapper) = + if !used + then + let label_pred = CTL.Pred (Lib_engine.Label(lv),CTL.Control) in + (ctl_and switch_header label_pred, + (function body -> quantify true [lv] body)) + else (switch_header,function x -> x) in + wrapper + (end_control_structure b1fvs switch_header body + after_pred (Some(ctl_ex after_pred)) None aft after label guard) + | Ast.FunDecl(header,lbrace,decls,body,rbrace) -> + let (hfvs,b1fvs,lbfvs,b2fvs,b3fvs,b4fvs,rbfvs) = + match + seq_fvs quantified + [Ast.get_fvs header;Ast.get_fvs lbrace;Ast.get_fvs decls; + Ast.get_fvs body;Ast.get_fvs rbrace] + with + [(hfvs,b1fvs);(lbfvs,b2fvs);(_,b3fvs);(_,b4fvs);(rbfvs,_)] -> + (hfvs,b1fvs,lbfvs,b2fvs,b3fvs,b4fvs,rbfvs) + | _ -> failwith "not possible" in + let (mhfvs,mb1fvs,mlbfvs,mb2fvs,mb3fvs,mb4fvs,mrbfvs) = + match + seq_fvs quantified + [Ast.get_mfvs header;Ast.get_mfvs lbrace;Ast.get_mfvs decls; + Ast.get_mfvs body;Ast.get_mfvs rbrace] + with + [(hfvs,b1fvs);(lbfvs,b2fvs);(_,b3fvs);(_,b4fvs);(rbfvs,_)] -> + (hfvs,b1fvs,lbfvs,b2fvs,b3fvs,b4fvs,rbfvs) + | _ -> failwith "not possible" in + let function_header = quantify guard hfvs (make_match header) in + let start_brace = quantify guard lbfvs (make_match lbrace) in + let stripped_rbrace = + match Ast.unwrap rbrace with + Ast.SeqEnd((data,info,_,_)) -> + Ast.rewrap rbrace(Ast.SeqEnd (Ast.make_mcode data)) + | _ -> failwith "unexpected close brace" in + let end_brace = + let exit = CTL.Pred (Lib_engine.Exit,CTL.Control) in + let errorexit = CTL.Pred (Lib_engine.ErrorExit,CTL.Control) in + let fake_brace = CTL.Pred (Lib_engine.FakeBrace,CTL.Control) in + ctl_and + (quantify guard rbfvs (make_match rbrace)) + (ctl_and + (* the following finds the beginning of the fake braces, + if there are any, not completely sure how this works. + sse the examples sw and return *) + (ctl_back_ex (ctl_not fake_brace)) + (ctl_au (make_match stripped_rbrace) (ctl_or exit errorexit))) in + let new_quantified3 = + Common.union_set b1fvs + (Common.union_set b2fvs (Common.union_set b3fvs quantified)) in + let new_quantified4 = Common.union_set b4fvs new_quantified3 in + let new_mquantified3 = + Common.union_set mb1fvs + (Common.union_set mb2fvs + (Common.union_set mb3fvs minus_quantified)) in + let new_mquantified4 = Common.union_set mb4fvs new_mquantified3 in + let fn_nest = + match (Ast.undots decls,Ast.undots body,contains_modif rbrace) with + ([],[body],false) -> + (match Ast.unwrap body with + Ast.Nest(stmt_dots,[],multi,_,_) -> + if multi + then None (* not sure how to optimize this case *) + else Some (Common.Left stmt_dots) + | Ast.Dots(_,whencode,_,_) when + (List.for_all + (* flow sensitive, so not optimizable *) + (function Ast.WhenNotTrue(_) | Ast.WhenNotFalse(_) -> + false + | _ -> true) whencode) -> + Some (Common.Right whencode) + | _ -> None) + | _ -> None in + let body_code = + match fn_nest with + Some (Common.Left stmt_dots) -> + (* special case for function header + body - header is unambiguous + and unique, so we can just look for the nested body anywhere + else in the CFG *) + CTL.AndAny + (CTL.FORWARD,guard_to_strict guard,start_brace, + statement_list stmt_dots + (* discards match on right brace, but don't need it *) + (Guard (make_seq_after end_brace after)) + new_quantified4 new_mquantified4 + None llabel slabel true guard) + | Some (Common.Right whencode) -> + (* try to be more efficient for the case where the body is just + ... Perhaps this is too much of a special case, but useful + for dropping a parameter and checking that it is never used. *) + make_seq + [start_brace; + match whencode with + [] -> CTL.True + | _ -> + let leftarg = + ctl_and + (ctl_not + (List.fold_left + (function prev -> + function + Ast.WhenAlways(s) -> prev + | Ast.WhenNot(sl) -> + let x = + statement_list sl Tail + new_quantified4 new_mquantified4 + label llabel slabel true true in + ctl_or prev x + | Ast.WhenNotTrue(_) | Ast.WhenNotFalse(_) -> + failwith "unexpected" + | Ast.WhenModifier(Ast.WhenAny) -> CTL.False + | Ast.WhenModifier(_) -> prev) + CTL.False whencode)) + (List.fold_left + (function prev -> + function + Ast.WhenAlways(s) -> + let x = + statement s Tail + new_quantified4 new_mquantified4 + label llabel slabel true in + ctl_and prev x + | Ast.WhenNot(sl) -> prev + | Ast.WhenNotTrue(_) | Ast.WhenNotFalse(_) -> + failwith "unexpected" + | Ast.WhenModifier(Ast.WhenAny) -> CTL.True + | Ast.WhenModifier(_) -> prev) + CTL.True whencode) in + ctl_au leftarg (make_match stripped_rbrace)] + | None -> + make_seq + [start_brace; + quantify guard b3fvs + (statement_list decls + (After + (quantify guard b4fvs + (statement_list body + (After (make_seq_after end_brace after)) + new_quantified4 new_mquantified4 + None llabel slabel true guard))) + new_quantified3 new_mquantified3 None llabel slabel + false guard)] in + quantify guard b1fvs + (make_seq [function_header; quantify guard b2fvs body_code]) + | Ast.Define(header,body) -> + let (hfvs,bfvs,bodyfvs) = + match seq_fvs quantified [Ast.get_fvs header;Ast.get_fvs body] + with + [(hfvs,b1fvs);(bodyfvs,_)] -> (hfvs,b1fvs,bodyfvs) + | _ -> failwith "not possible" in + let (mhfvs,mbfvs,mbodyfvs) = + match seq_fvs minus_quantified [Ast.get_mfvs header;Ast.get_mfvs body] + with + [(hfvs,b1fvs);(bodyfvs,_)] -> (hfvs,b1fvs,bodyfvs) + | _ -> failwith "not possible" in + let define_header = quantify guard hfvs (make_match header) in + let body_code = + statement_list body after + (Common.union_set bfvs quantified) + (Common.union_set mbfvs minus_quantified) + None llabel slabel true guard in + quantify guard bfvs (make_seq [define_header; body_code]) + | Ast.OptStm(stm) -> + failwith "OptStm should have been compiled away\n" + | Ast.UniqueStm(stm) -> failwith "arities not yet supported" + | _ -> failwith "not supported" in + if guard or !dots_done + then term + else + do_between_dots stmt term after quantified minus_quantified + label llabel slabel guard + +(* term is the translation of stmt *) +and do_between_dots stmt term after quantified minus_quantified + label llabel slabel guard = + match Ast.get_dots_bef_aft stmt with + Ast.AddingBetweenDots (brace_term,n) + | Ast.DroppingBetweenDots (brace_term,n) -> + let match_brace = + statement brace_term after quantified minus_quantified + label llabel slabel guard in + let v = Printf.sprintf "_r_%d" n in + let case1 = ctl_and CTL.NONSTRICT (CTL.Ref v) match_brace in + let case2 = ctl_and CTL.NONSTRICT (ctl_not (CTL.Ref v)) term in + CTL.Let + (v,ctl_or + (ctl_back_ex (ctl_or (truepred label) (inlooppred label))) + (ctl_back_ex (ctl_back_ex (falsepred label))), + ctl_or case1 case2) + | Ast.NoDots -> term + +(* un_process_bef_aft is because we don't want to do transformation in this + code, and thus don't case about braces before or after it *) +and process_bef_aft quantified minus_quantified label llabel slabel guard = + function + Ast.WParen (re,n) -> + let paren_pred = CTL.Pred (Lib_engine.Paren n,CTL.Control) in + let s = guard_to_strict guard in + quantify true (get_unquantified quantified [n]) + (ctl_and s (make_raw_match None guard re) paren_pred) + | Ast.Other s -> + statement s Tail quantified minus_quantified label llabel slabel guard + | Ast.Other_dots d -> + statement_list d Tail quantified minus_quantified + label llabel slabel true guard + +(* --------------------------------------------------------------------- *) +(* cleanup: convert AX to EX for pdots. +Concretely: AX(A[...] & E[...]) becomes AX(A[...]) & EX(E[...]) +This is what we wanted in the first place, but it wasn't possible to make +because the AX and its argument are not created in the same place. +Rather clunky... *) +(* also cleanup XX, which is a marker for the case where the programmer +specifies to change the quantifier on .... Assumed to only occur after one AX +or EX, or at top level. *) + +let rec cleanup c = + let c = match c with CTL.XX(c) -> c | _ -> c in + match c with + CTL.False -> CTL.False + | CTL.True -> CTL.True + | CTL.Pred(p) -> CTL.Pred(p) + | CTL.Not(phi) -> CTL.Not(cleanup phi) + | CTL.Exists(keep,v,phi) -> CTL.Exists(keep,v,cleanup phi) + | CTL.AndAny(dir,s,phi1,phi2) -> + CTL.AndAny(dir,s,cleanup phi1,cleanup phi2) + | CTL.HackForStmt(dir,s,phi1,phi2) -> + CTL.HackForStmt(dir,s,cleanup phi1,cleanup phi2) + | CTL.And(s,phi1,phi2) -> CTL.And(s,cleanup phi1,cleanup phi2) + | CTL.Or(phi1,phi2) -> CTL.Or(cleanup phi1,cleanup phi2) + | CTL.SeqOr(phi1,phi2) -> CTL.SeqOr(cleanup phi1,cleanup phi2) + | CTL.Implies(phi1,phi2) -> CTL.Implies(cleanup phi1,cleanup phi2) + | CTL.AF(dir,s,phi1) -> CTL.AF(dir,s,cleanup phi1) + | CTL.AX(CTL.FORWARD,s, + CTL.Let(v1,e1, + CTL.And(CTL.NONSTRICT,CTL.AU(CTL.FORWARD,s2,e2,e3), + CTL.EU(CTL.FORWARD,e4,e5)))) -> + CTL.Let(v1,e1, + CTL.And(CTL.NONSTRICT, + CTL.AX(CTL.FORWARD,s,CTL.AU(CTL.FORWARD,s2,e2,e3)), + CTL.EX(CTL.FORWARD,CTL.EU(CTL.FORWARD,e4,e5)))) + | CTL.AX(dir,s,CTL.XX(phi)) -> CTL.EX(dir,cleanup phi) + | CTL.EX(dir,CTL.XX((CTL.AU(_,s,_,_)) as phi)) -> + CTL.AX(dir,s,cleanup phi) + | CTL.XX(phi) -> failwith "bad XX" + | CTL.AX(dir,s,phi1) -> CTL.AX(dir,s,cleanup phi1) + | CTL.AG(dir,s,phi1) -> CTL.AG(dir,s,cleanup phi1) + | CTL.EF(dir,phi1) -> CTL.EF(dir,cleanup phi1) + | CTL.EX(dir,phi1) -> CTL.EX(dir,cleanup phi1) + | CTL.EG(dir,phi1) -> CTL.EG(dir,cleanup phi1) + | CTL.AW(dir,s,phi1,phi2) -> CTL.AW(dir,s,cleanup phi1,cleanup phi2) + | CTL.AU(dir,s,phi1,phi2) -> CTL.AU(dir,s,cleanup phi1,cleanup phi2) + | CTL.EU(dir,phi1,phi2) -> CTL.EU(dir,cleanup phi1,cleanup phi2) + | CTL.Let (x,phi1,phi2) -> CTL.Let (x,cleanup phi1,cleanup phi2) + | CTL.LetR (dir,x,phi1,phi2) -> CTL.LetR (dir,x,cleanup phi1,cleanup phi2) + | CTL.Ref(s) -> CTL.Ref(s) + | CTL.Uncheck(phi1) -> CTL.Uncheck(cleanup phi1) + | CTL.InnerAnd(phi1) -> CTL.InnerAnd(cleanup phi1) + +(* --------------------------------------------------------------------- *) +(* Function declaration *) + +let top_level name (ua,pos) t = + let ua = List.filter (function (nm,_) -> nm = name) ua in + used_after := ua; + saved := Ast.get_saved t; + let quantified = Common.minus_set ua pos in + quantify false quantified + (match Ast.unwrap t with + Ast.FILEINFO(old_file,new_file) -> failwith "not supported fileinfo" + | Ast.DECL(stmt) -> + let unopt = elim_opt.V.rebuilder_statement stmt in + let unopt = preprocess_dots_e unopt in + cleanup(statement unopt VeryEnd quantified [] None None None false) + | Ast.CODE(stmt_dots) -> + let unopt = elim_opt.V.rebuilder_statement_dots stmt_dots in + let unopt = preprocess_dots unopt in + let starts_with_dots = + match Ast.undots stmt_dots with + d::ds -> + (match Ast.unwrap d with + Ast.Dots(_,_,_,_) | Ast.Circles(_,_,_,_) + | Ast.Stars(_,_,_,_) -> true + | _ -> false) + | _ -> false in + let starts_with_brace = + match Ast.undots stmt_dots with + d::ds -> + (match Ast.unwrap d with + Ast.Seq(_) -> true + | _ -> false) + | _ -> false in + let res = + statement_list unopt VeryEnd quantified [] None None None + false false in + cleanup + (if starts_with_dots + then + (* EX because there is a loop on enter/top *) + ctl_and CTL.NONSTRICT (toppred None) (ctl_ex res) + else if starts_with_brace + then + ctl_and CTL.NONSTRICT + (ctl_not(CTL.EX(CTL.BACKWARD,(funpred None)))) res + else res) + | Ast.ERRORWORDS(exps) -> failwith "not supported errorwords") + +(* --------------------------------------------------------------------- *) +(* Entry points *) + +let asttoctlz (name,(_,_,exists_flag),l) used_after positions = + letctr := 0; + labelctr := 0; + (match exists_flag with + Ast.Exists -> exists := Exists + | Ast.Forall -> exists := Forall + | Ast.ReverseForall -> exists := ReverseForall + | Ast.Undetermined -> + exists := if !Flag.sgrep_mode2 then Exists else Forall); + + let (l,used_after) = + List.split + (List.filter + (function (t,_) -> + match Ast.unwrap t with Ast.ERRORWORDS(exps) -> false | _ -> true) + (List.combine l (List.combine used_after positions))) in + let res = List.map2 (top_level name) used_after l in + exists := Forall; + res + +let asttoctl r used_after positions = + match r with + Ast.ScriptRule _ -> [] + | Ast.CocciRule (a,b,c,_) -> asttoctlz (a,b,c) used_after positions + +let pp_cocci_predicate (pred,modif) = + Pretty_print_engine.pp_predicate pred + +let cocci_predicate_to_string (pred,modif) = + Pretty_print_engine.predicate_to_string pred diff --git a/engine/.depend b/engine/.depend index cd7367f..4c9bde7 100644 --- a/engine/.depend +++ b/engine/.depend @@ -14,6 +14,9 @@ ctlcocci_integration.cmi: ../commons/ograph_extended.cmi lib_engine.cmo \ ../parsing_cocci/ast_cocci.cmi ctltotex.cmi: ../ctl/wrapper_ctl.cmi lib_engine.cmo ../ctl/ast_ctl.cmo \ ../parsing_cocci/ast_cocci.cmi +lib_matcher_c.cmi: ../commons/ograph_extended.cmi \ + ../parsing_c/control_flow_c.cmi ../parsing_cocci/ast_cocci.cmi \ + ../parsing_c/ast_c.cmo pattern_c.cmi: lib_engine.cmo ../parsing_c/control_flow_c.cmi \ ../parsing_cocci/ast_cocci.cmi postprocess_transinfo.cmi: ../commons/ograph_extended.cmi lib_engine.cmo \ @@ -99,6 +102,14 @@ lib_engine.cmo: ../ctl/wrapper_ctl.cmi ../commons/ograph_extended.cmi \ lib_engine.cmx: ../ctl/wrapper_ctl.cmx ../commons/ograph_extended.cmx \ ../parsing_c/control_flow_c.cmx ../commons/common.cmx ../ctl/ast_ctl.cmx \ ../parsing_cocci/ast_cocci.cmx ../parsing_c/ast_c.cmx +lib_matcher_c.cmo: ../parsing_c/visitor_c.cmi pattern_c.cmi \ + ../commons/ograph_extended.cmi ../parsing_c/lib_parsing_c.cmo \ + ../parsing_c/control_flow_c.cmi ../commons/common.cmi \ + ../parsing_cocci/ast_cocci.cmi ../parsing_c/ast_c.cmo lib_matcher_c.cmi +lib_matcher_c.cmx: ../parsing_c/visitor_c.cmx pattern_c.cmx \ + ../commons/ograph_extended.cmx ../parsing_c/lib_parsing_c.cmx \ + ../parsing_c/control_flow_c.cmx ../commons/common.cmx \ + ../parsing_cocci/ast_cocci.cmx ../parsing_c/ast_c.cmx lib_matcher_c.cmi main.cmo: ../parsing_cocci/parse_cocci.cmi ctltotex.cmi asttoctl.cmi main.cmx: ../parsing_cocci/parse_cocci.cmx ctltotex.cmx asttoctl.cmx pattern_c.cmo: ../parsing_c/visitor_c.cmi ../parsing_c/lib_parsing_c.cmo \ diff --git a/engine/Makefile b/engine/Makefile index 105528d..80d5b28 100644 --- a/engine/Makefile +++ b/engine/Makefile @@ -31,7 +31,7 @@ SRC= flag_matcher.ml lib_engine.ml pretty_print_engine.ml \ c_vs_c.ml isomorphisms_c_c.ml \ cocci_vs_c.ml pattern_c.ml sgrep.ml transformation_c.ml \ asttomember.ml asttoctl2.ml ctltotex.ml \ - postprocess_transinfo.ml ctlcocci_integration.ml + postprocess_transinfo.ml ctlcocci_integration.ml lib_matcher_c.ml #c_vs_c.ml #SRC= flag_matcher.ml \ diff --git a/engine/asttoctl2.ml b/engine/asttoctl2.ml index 6b2a340..561acff 100644 --- a/engine/asttoctl2.ml +++ b/engine/asttoctl2.ml @@ -433,7 +433,7 @@ let and_after guard first rest = let contains_modif = let bind x y = x or y in let option_default = false in - let mcode r (_,_,kind,_) = + let mcode r (_,_,kind,metapos) = match kind with Ast.MINUS(_,_) -> true | Ast.PLUS -> failwith "not possible" @@ -455,6 +455,30 @@ let contains_modif = do_nothing rule_elem do_nothing do_nothing do_nothing do_nothing in recursor.V.combiner_rule_elem +let contains_pos = + let bind x y = x or y in + let option_default = false in + let mcode r (_,_,kind,metapos) = + match metapos with + Ast.MetaPos(_,_,_,_,_) -> true + | Ast.NoMetaPos -> false in + let do_nothing r k e = k e in + let rule_elem r k re = + let res = k re in + match Ast.unwrap re with + Ast.FunHeader(bef,_,fninfo,name,lp,params,rp) -> + bind (mcode r ((),(),bef,Ast.NoMetaPos)) res + | Ast.Decl(bef,_,decl) -> bind (mcode r ((),(),bef,Ast.NoMetaPos)) res + | _ -> res in + let recursor = + V.combiner bind option_default + mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode + mcode + do_nothing do_nothing do_nothing do_nothing + do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing + do_nothing rule_elem do_nothing do_nothing do_nothing do_nothing in + recursor.V.combiner_rule_elem + (* code is not a DisjRuleElem *) let make_match label guard code = let v = fresh_var() in @@ -658,7 +682,9 @@ and get_before_e s a = let (de,dea) = get_before decls [] in let (bd,_) = get_before body dea in (Ast.rewrap s (Ast.FunDecl(header,lbrace,de,bd,rbrace)),[]) - | _ -> failwith "get_before_e: not supported" + | _ -> + Pretty_print_cocci.statement "" s; Format.print_newline(); + failwith "get_before_e: not supported" let rec get_after sl a = match Ast.unwrap sl with @@ -2026,7 +2052,8 @@ and statement stmt after quantified minus_quantified (Common.union_set mb3fvs minus_quantified)) in let new_mquantified4 = Common.union_set mb4fvs new_mquantified3 in let fn_nest = - match (Ast.undots decls,Ast.undots body,contains_modif rbrace) with + match (Ast.undots decls,Ast.undots body, + contains_modif rbrace or contains_pos rbrace) with ([],[body],false) -> (match Ast.unwrap body with Ast.Nest(stmt_dots,[],multi,_,_) -> diff --git a/engine/cocci_vs_c.ml b/engine/cocci_vs_c.ml index ed20853..7cf2233 100644 --- a/engine/cocci_vs_c.ml +++ b/engine/cocci_vs_c.ml @@ -3212,9 +3212,14 @@ let rec (rule_elem_node: (A.rule_elem, Control_flow_c.node) matcher) = f_storage = stob; f_attr = attrs; f_body = body; + f_old_c_style = oldstyle; }, ii) -> assert (null body); + if oldstyle <> None + then pr2 "OLD STYLE DECL NOT WELL SUPPORTED"; + + (* fninfoa records the order in which the SP specified the various information, but this isn't taken into account in the matching. Could this be a problem for transformation? *) @@ -3276,6 +3281,7 @@ let rec (rule_elem_node: (A.rule_elem, Control_flow_c.node) matcher) = f_storage = stob; f_attr = attrs; f_body = body; + f_old_c_style = oldstyle; (* TODO *) }, iidb::ioparenb::icparenb::iifakestart::iistob) ) diff --git a/engine/cocci_vs_c.mli b/engine/cocci_vs_c.mli index 3e28251..dfe7db7 100644 --- a/engine/cocci_vs_c.mli +++ b/engine/cocci_vs_c.mli @@ -176,7 +176,7 @@ module COCCI_VS_C : val expression : (Ast_cocci.expression, Ast_c.expression) matcher - (* there is far more functions in this functor but they do not have + (* there are far more functions in this functor but they do not have * to be exported *) diff --git a/engine/lib_matcher_c.ml b/engine/lib_matcher_c.ml new file mode 100644 index 0000000..1210e5c --- /dev/null +++ b/engine/lib_matcher_c.ml @@ -0,0 +1,134 @@ +open Common + +(*****************************************************************************) +(* Types *) +(*****************************************************************************) + +type protocol_match = + | MatchPos of Ograph_extended.nodei + | MatchNeg of Ograph_extended.nodei + | NoMatch + (* could generate exn instead, but in many cases as for my acomment gui + * I still want to print the match for the other elements, so one failure + * should not stop everything + *) + | MatchProblem of string + + +(*****************************************************************************) +(* Helpers *) +(*****************************************************************************) + +(*****************************************************************************) +(* Specific finder wrappers *) +(*****************************************************************************) +let (find_nodes_satisfying_pattern: + Control_flow_c.cflow -> Ast_cocci.rule_elem -> Ograph_extended.nodei list)= + fun flow pattern -> + + let nodes = flow#nodes in + let nodes = nodes#tolist in + nodes +> Common.map_filter (fun (nodei, node) -> + let res = + Pattern_c.match_re_node [] (* dropped isos *) + pattern node + [] + in + if List.length res > 0 + then Some nodei + else None + ) + + +let (find_nodes_containing_expr: + Control_flow_c.cflow -> Ast_c.expression -> Ograph_extended.nodei list)= + fun flow expr -> + + let expr = Lib_parsing_c.real_al_expr expr in + + let nodes = flow#nodes in + let nodes = nodes#tolist in + nodes +> Common.map_filter (fun (nodei, node) -> + let node = Lib_parsing_c.real_al_node node in + + let found = ref false in + + Visitor_c.vk_node { Visitor_c.default_visitor_c with + Visitor_c.kexpr = (fun (k, bigf) e2 -> + if e2 =*= expr + then found := true + else k e2 + ); + } node; + + if !found + then Some nodei + else None + ) + + + +(*****************************************************************************) +(* Main entries *) +(*****************************************************************************) + +(* + * + * todo: Check for all path upwards ? + *) + +let (find_nodes_upward_satisfying_protocol: + Ograph_extended.nodei -> Control_flow_c.cflow -> + Ast_cocci.rule_elem * Ast_cocci.rule_elem -> + protocol_match + ) = + fun nodei flow (pattern1, pattern2) -> + + let already_done = ref [nodei] in + let found = ref [] in + + let rec aux nodei = + let pred = + List.map fst ((flow#predecessors nodei)#tolist) + in + pred +> List.iter (fun nodei2 -> + if List.mem nodei2 !already_done + then () + else begin + Common.push2 nodei2 already_done; + + let node2 = flow#nodes#assoc nodei2 in + + let res1 = + Pattern_c.match_re_node [] + pattern1 node2 + [] + in + let res2 = + Pattern_c.match_re_node [] + pattern2 node2 + [] + in + match List.length res1 > 0, List.length res2 > 0 with + | true, false -> + Common.push2 (MatchPos nodei2) found + | false, true -> + Common.push2 (MatchNeg nodei2) found + | true, true -> + failwith "wierd, node match both rule_elem" + | false, false -> + aux nodei2 + end + ); + in + aux nodei; + (match !found with + | [] -> NoMatch + | [x] -> x + | x::y::ys -> + failwith "multiple found"; + ) + + + + diff --git a/engine/lib_matcher_c.mli b/engine/lib_matcher_c.mli new file mode 100644 index 0000000..7b42611 --- /dev/null +++ b/engine/lib_matcher_c.mli @@ -0,0 +1,21 @@ + +(* a protocol is for the moment represented as 2 rule_elem, a positive + * pattern (e.g. spin_lock_irq()) and negative one (e.g. spin_unlock_irq()) + *) +type protocol_match = + | MatchPos of Ograph_extended.nodei + | MatchNeg of Ograph_extended.nodei + | NoMatch + | MatchProblem of string + + +val find_nodes_satisfying_pattern: + Control_flow_c.cflow -> Ast_cocci.rule_elem -> Ograph_extended.nodei list +val find_nodes_containing_expr: + Control_flow_c.cflow -> Ast_c.expression -> Ograph_extended.nodei list + + +val find_nodes_upward_satisfying_protocol: + Ograph_extended.nodei -> Control_flow_c.cflow -> + Ast_cocci.rule_elem * Ast_cocci.rule_elem -> + protocol_match diff --git a/globals/config.ml b/globals/config.ml index f2d0bbd..92821be 100644 --- a/globals/config.ml +++ b/globals/config.ml @@ -1,4 +1,4 @@ -let version = "0.1.2" +let version = "0.1.3" let path = try (Sys.getenv "COCCINELLE_HOME") diff --git a/globals/flag.ml b/globals/flag.ml index ebee85e..0e9c29e 100644 --- a/globals/flag.ml +++ b/globals/flag.ml @@ -18,4 +18,3 @@ let make_hrule = ref (None : string (*dir*) option) let currentfile = ref (None : string option) let current_element = ref "" - diff --git a/parsing_c/.depend b/parsing_c/.depend index 33810a6..c705566 100644 --- a/parsing_c/.depend +++ b/parsing_c/.depend @@ -1,32 +1,33 @@ ast_to_flow.cmi: control_flow_c.cmi ../commons/common.cmi ast_c.cmo compare_c.cmi: ../commons/common.cmi control_flow_c.cmi: ../commons/ograph_extended.cmi ast_c.cmo -cpp_ast_c.cmi: ../commons/common.cmi ast_c.cmo +cpp_ast_c.cmi: parsing_stat.cmo parse_c.cmi ../commons/common.cmi ast_c.cmo lexer_parser.cmi: ../commons/common.cmi parse_c.cmi: parsing_stat.cmo parsing_hacks.cmi parser_c.cmi \ ../commons/common.cmi ast_c.cmo parser_c.cmi: ast_c.cmo parsing_hacks.cmi: parser_c.cmi ../commons/common.cmi -pretty_print_c.cmi: control_flow_c.cmi ast_c.cmo +pretty_print_c.cmi: ../commons/ograph_extended.cmi control_flow_c.cmi \ + ast_c.cmo test_parsing_c.cmi: ../commons/common.cmi token_helpers.cmi: parser_c.cmi ../commons/common.cmi ast_c.cmo type_annoter_c.cmi: ../commons/common.cmi ast_c.cmo +type_c.cmi: ast_c.cmo unparse_c.cmi: parse_c.cmi ../commons/common.cmi -unparse_c2.cmi: parse_c.cmi ../commons/common.cmi unparse_cocci.cmi: pretty_print_c.cmi ../parsing_cocci/ast_cocci.cmi \ ast_c.cmo -unparse_cocci2.cmi: pretty_print_c.cmi ../parsing_cocci/ast_cocci.cmi \ - ast_c.cmo unparse_hrule.cmi: parse_c.cmi ../commons/common.cmi visitor_c.cmi: control_flow_c.cmi ../commons/common.cmi ast_c.cmo ast_c.cmo: ../commons/common.cmi ../parsing_cocci/ast_cocci.cmi ast_c.cmx: ../commons/common.cmx ../parsing_cocci/ast_cocci.cmx ast_to_flow.cmo: visitor_c.cmi ../commons/ograph_extended.cmi \ - ../commons/oassocb.cmo ../commons/oassoc.cmi flag_parsing_c.cmo \ - control_flow_c.cmi ../commons/common.cmi ast_c.cmo ast_to_flow.cmi + ../commons/ocollection/oassocb.cmo ../commons/oassoc.cmi \ + flag_parsing_c.cmo control_flow_c.cmi ../commons/common.cmi ast_c.cmo \ + ast_to_flow.cmi ast_to_flow.cmx: visitor_c.cmx ../commons/ograph_extended.cmx \ - ../commons/oassocb.cmx ../commons/oassoc.cmx flag_parsing_c.cmx \ - control_flow_c.cmx ../commons/common.cmx ast_c.cmx ast_to_flow.cmi + ../commons/ocollection/oassocb.cmx ../commons/oassoc.cmx \ + flag_parsing_c.cmx control_flow_c.cmx ../commons/common.cmx ast_c.cmx \ + ast_to_flow.cmi compare_c.cmo: visitor_c.cmi token_helpers.cmi parser_c.cmi parse_c.cmi \ lib_parsing_c.cmo flag_parsing_c.cmo ../commons/common.cmi ast_c.cmo \ compare_c.cmi @@ -47,9 +48,9 @@ lexer_c.cmo: parser_c.cmi flag_parsing_c.cmo ../commons/common.cmi ast_c.cmo lexer_c.cmx: parser_c.cmx flag_parsing_c.cmx ../commons/common.cmx ast_c.cmx lexer_parser.cmo: flag_parsing_c.cmo ../commons/common.cmi lexer_parser.cmi lexer_parser.cmx: flag_parsing_c.cmx ../commons/common.cmx lexer_parser.cmi -lib_parsing_c.cmo: visitor_c.cmi ../commons/common.cmi \ +lib_parsing_c.cmo: visitor_c.cmi ../globals/flag.cmo ../commons/common.cmi \ ../parsing_cocci/ast_cocci.cmi ast_c.cmo -lib_parsing_c.cmx: visitor_c.cmx ../commons/common.cmx \ +lib_parsing_c.cmx: visitor_c.cmx ../globals/flag.cmx ../commons/common.cmx \ ../parsing_cocci/ast_cocci.cmx ast_c.cmx parse_c.cmo: visitor_c.cmi token_helpers.cmi semantic_c.cmo parsing_stat.cmo \ parsing_hacks.cmi parser_c.cmi lexer_parser.cmi lexer_c.cmo \ @@ -69,48 +70,42 @@ parsing_hacks.cmx: token_helpers.cmx parsing_stat.cmx parser_c.cmx \ parsing_hacks.cmi parsing_stat.cmo: ../commons/common.cmi parsing_stat.cmx: ../commons/common.cmx -pretty_print_c.cmo: flag_parsing_c.cmo control_flow_c.cmi \ - ../commons/common.cmi ast_c.cmo pretty_print_c.cmi -pretty_print_c.cmx: flag_parsing_c.cmx control_flow_c.cmx \ - ../commons/common.cmx ast_c.cmx pretty_print_c.cmi +pretty_print_c.cmo: ../commons/ograph_extended.cmi lib_parsing_c.cmo \ + flag_parsing_c.cmo control_flow_c.cmi ../commons/common.cmi ast_c.cmo \ + pretty_print_c.cmi +pretty_print_c.cmx: ../commons/ograph_extended.cmx lib_parsing_c.cmx \ + flag_parsing_c.cmx control_flow_c.cmx ../commons/common.cmx ast_c.cmx \ + pretty_print_c.cmi semantic_c.cmo: ../commons/common.cmi semantic_c.cmx: ../commons/common.cmx -test_parsing_c.cmo: unparse_c.cmi type_annoter_c.cmi parsing_stat.cmo \ - parse_c.cmi ../commons/ograph_extended.cmi flag_parsing_c.cmo \ - compare_c.cmi ../commons/common.cmi ast_to_flow.cmi ast_c.cmo \ - test_parsing_c.cmi -test_parsing_c.cmx: unparse_c.cmx type_annoter_c.cmx parsing_stat.cmx \ - parse_c.cmx ../commons/ograph_extended.cmx flag_parsing_c.cmx \ - compare_c.cmx ../commons/common.cmx ast_to_flow.cmx ast_c.cmx \ - test_parsing_c.cmi +test_parsing_c.cmo: visitor_c.cmi unparse_c.cmi type_annoter_c.cmi \ + parsing_stat.cmo parse_c.cmi ../commons/ograph_extended.cmi \ + flag_parsing_c.cmo cpp_ast_c.cmi compare_c.cmi ../commons/common.cmi \ + ast_to_flow.cmi ast_c.cmo test_parsing_c.cmi +test_parsing_c.cmx: visitor_c.cmx unparse_c.cmx type_annoter_c.cmx \ + parsing_stat.cmx parse_c.cmx ../commons/ograph_extended.cmx \ + flag_parsing_c.cmx cpp_ast_c.cmx compare_c.cmx ../commons/common.cmx \ + ast_to_flow.cmx ast_c.cmx test_parsing_c.cmi token_helpers.cmo: parser_c.cmi ../commons/common.cmi ast_c.cmo \ token_helpers.cmi token_helpers.cmx: parser_c.cmx ../commons/common.cmx ast_c.cmx \ token_helpers.cmi -type_annoter_c.cmo: visitor_c.cmi parse_c.cmi lib_parsing_c.cmo \ +type_annoter_c.cmo: visitor_c.cmi type_c.cmi parse_c.cmi lib_parsing_c.cmo \ flag_parsing_c.cmo ../commons/common.cmi ast_c.cmo type_annoter_c.cmi -type_annoter_c.cmx: visitor_c.cmx parse_c.cmx lib_parsing_c.cmx \ +type_annoter_c.cmx: visitor_c.cmx type_c.cmx parse_c.cmx lib_parsing_c.cmx \ flag_parsing_c.cmx ../commons/common.cmx ast_c.cmx type_annoter_c.cmi +type_c.cmo: ../commons/common.cmi ast_c.cmo type_c.cmi +type_c.cmx: ../commons/common.cmx ast_c.cmx type_c.cmi unparse_c.cmo: visitor_c.cmi unparse_cocci.cmi token_helpers.cmi \ pretty_print_c.cmi parser_c.cmi flag_parsing_c.cmo ../commons/common.cmi \ ../parsing_cocci/ast_cocci.cmi ast_c.cmo unparse_c.cmi unparse_c.cmx: visitor_c.cmx unparse_cocci.cmx token_helpers.cmx \ pretty_print_c.cmx parser_c.cmx flag_parsing_c.cmx ../commons/common.cmx \ ../parsing_cocci/ast_cocci.cmx ast_c.cmx unparse_c.cmi -unparse_c2.cmo: visitor_c.cmi unparse_cocci2.cmi token_helpers.cmi \ - pretty_print_c.cmi parser_c.cmi flag_parsing_c.cmo ../commons/common.cmi \ - ../parsing_cocci/ast_cocci.cmi ast_c.cmo unparse_c2.cmi -unparse_c2.cmx: visitor_c.cmx unparse_cocci2.cmx token_helpers.cmx \ - pretty_print_c.cmx parser_c.cmx flag_parsing_c.cmx ../commons/common.cmx \ - ../parsing_cocci/ast_cocci.cmx ast_c.cmx unparse_c2.cmi unparse_cocci.cmo: pretty_print_c.cmi ../commons/common.cmi \ ../parsing_cocci/ast_cocci.cmi ast_c.cmo unparse_cocci.cmi unparse_cocci.cmx: pretty_print_c.cmx ../commons/common.cmx \ ../parsing_cocci/ast_cocci.cmx ast_c.cmx unparse_cocci.cmi -unparse_cocci2.cmo: pretty_print_c.cmi ../commons/common.cmi \ - ../parsing_cocci/ast_cocci.cmi ast_c.cmo unparse_cocci2.cmi -unparse_cocci2.cmx: pretty_print_c.cmx ../commons/common.cmx \ - ../parsing_cocci/ast_cocci.cmx ast_c.cmx unparse_cocci2.cmi unparse_hrule.cmo: unparse_c.cmi token_helpers.cmi pretty_print_c.cmi \ parser_c.cmi ../commons/common.cmi ../parsing_cocci/ast_cocci.cmi \ ast_c.cmo unparse_hrule.cmi diff --git a/parsing_c/Makefile b/parsing_c/Makefile index ea1b150..79db28e 100644 --- a/parsing_c/Makefile +++ b/parsing_c/Makefile @@ -6,7 +6,7 @@ TARGET=parsing_c # - type_cocci.ml ast_cocci.ml # + unparse_hrule SRC= flag_parsing_c.ml parsing_stat.ml \ - ast_c.ml control_flow_c.ml \ + ast_c.ml control_flow_c.ml type_c.ml \ visitor_c.ml lib_parsing_c.ml \ ast_to_flow.ml \ pretty_print_c.ml \ @@ -29,7 +29,8 @@ SRC= flag_parsing_c.ml parsing_stat.ml \ LIBS=../commons/commons.cma ../globals/globals.cma \ ../parsing_cocci/cocci_parser.cma -INCLUDES= -I ../commons -I ../globals -I ../parsing_cocci +INCLUDES= -I ../commons -I ../commons/ocamlextra -I ../commons/ocollection \ + -I ../globals -I ../parsing_cocci #LIBS=../commons/commons.cma #INCLUDES= -I ../commons diff --git a/parsing_c/ast_c.ml b/parsing_c/ast_c.ml index 5d74a7d..30a3cf2 100644 --- a/parsing_c/ast_c.ml +++ b/parsing_c/ast_c.ml @@ -73,7 +73,7 @@ open Common (* forunparser: *) -type posl = int * int (* lin-col, for MetaPosValList, for position variables *) +type posl = int * int (* line-col, for MetaPosValList, for position variables *) (* the virtual position is set in Parsing_hacks.insert_virtual_positions *) type virtual_position = Common.parse_info * int (* character offset *) @@ -94,7 +94,7 @@ type parse_info = type info = { pinfo : parse_info; - (* this tag can be changed, which is how we can express some progra + (* this tag can be changed, which is how we can express some program * transformations by tagging the tokens involved in this transformation. *) cocci_tag: (Ast_cocci.mcodekind * metavars_binding) ref; @@ -116,14 +116,15 @@ and 'a wrap2 = 'a * il (* Could have more precise type in fullType, in expression, etc, but * it requires to do too much things in parsing such as checking no * conflicting structname, computing value, etc. Better to separate - * concern, so I put '=>' to mean what we would really like. In fact + * concern. So I put '=>' to mean what we would really like. In fact * what we really like is defining another fullType, expression, etc * from scratch, because many stuff are just sugar. * * invariant: Array and FunctionType have also typeQualifier but they * dont have sense. I put this to factorise some code. If you look in - * grammar, you see that we can never specify const for the array - * himself (but we can do it for pointer). + * the grammar, you see that we can never specify const for the array + * himself (but we can do it for pointer) or function, we always + * have in the action rule of the grammar a { (nQ, FunctionType ...) }. * * * Because of ExprStatement, we can have more 'new scope' events, but @@ -267,12 +268,16 @@ and expression = (expressionbis * exp_info ref (* semantic: *)) wrap | Sequence of expression * expression | Assignment of expression * assignOp * expression - | Postfix of expression * fixOp - | Infix of expression * fixOp + + | Postfix of expression * fixOp + | Infix of expression * fixOp + | Unary of expression * unaryOp | Binary of expression * binaryOp * expression - | ArrayAccess of expression * expression + | ArrayAccess of expression * expression + + (* field ident access *) | RecordAccess of expression * string | RecordPtAccess of expression * string (* redundant normally, could replace it by DeRef RecordAcces *) @@ -484,6 +489,7 @@ and declaration = * parameter wheras a function definition can not. But, in some cases such * as 'f(void) {', there is no name too, so I simplified and reused the * same functionType type for both declaration and function definition. + * Also old style C does not have type in the parameter. *) and definition = definitionbis wrap (* s ( ) { } fakestart sto *) and definitionbis = @@ -492,6 +498,7 @@ and definition = definitionbis wrap (* s ( ) { } fakestart sto *) f_storage: storage; f_body: compound; f_attr: attribute list; (* gccext: *) + f_old_c_style: declaration list option; } (* cppext: IfdefFunHeader TODO *) @@ -526,10 +533,12 @@ and define = string wrap * define_body (* #define s *) | DefineVar | DefineFunc of ((string wrap) wrap2 list) wrap (* () *) and define_val = - | DefineExpr of expression + | DefineExpr of expression (* most common case, to define int constant *) + | DefineStmt of statement | DefineType of fullType | DefineDoWhileZero of (statement * expression) wrap (* do { } while(0) *) + | DefineFunction of definition | DefineInit of initialiser (* in practice only { } with possible ',' *) (* TODO DefineMulti of define_val list *) @@ -744,11 +753,17 @@ let set_type_expr ((unwrap_e, oldtyp), iie) newtyp = oldtyp := newtyp (* old: (unwrap_e, newtyp), iie *) +let get_onlytype_expr ((unwrap_e, typ), iie) = + match !typ with + | Some (ft,_local), _test -> Some ft + | None, _ -> None + let unwrap_typeC (qu, (typeC, ii)) = typeC let rewrap_typeC (qu, (typeC, ii)) newtypeC = (qu, (newtypeC, ii)) +(* ------------------------------------------------------------------------- *) let rewrap_str s ii = {ii with pinfo = (match ii.pinfo with @@ -817,6 +832,7 @@ let is_origintok ii = | OriginTok pi -> true | _ -> false +(* ------------------------------------------------------------------------- *) type posrv = Real of Common.parse_info | Virt of virtual_position let compare_pos ii1 ii2 = @@ -868,6 +884,9 @@ let is_test (e : expression) = * ocaml '=' to compare Ast elements. To overcome this problem, to be * able to use again '=', we just have to get rid of all those extra * information, to "abstract those line" (al) information. + * + * Julia then modifies it a little to have a tokenindex, so the original + * true al_info is in fact real_al_info. *) let al_info tokenindex x = @@ -888,6 +907,21 @@ let semi_al_info x = comments_tag = ref emptyComments; } +let magic_real_number = -10 + +let real_al_info x = + { pinfo = + (AbstractLineTok + {charpos = magic_real_number; + line = magic_real_number; + column = magic_real_number; + file = ""; + str = str_of_info x}); + cocci_tag = ref emptyAnnot; + comments_tag = ref emptyComments; + } + + (*****************************************************************************) (* Views *) (*****************************************************************************) @@ -942,7 +976,7 @@ let rec stmt_elems_of_sequencable xs = | CppDirectiveStmt _ | IfdefStmt _ -> - pr2 ("stmt_elems_of_sequencable: filter a directive"); + pr2_once ("stmt_elems_of_sequencable: filter a directive"); [] | IfdefStmt2 (_ifdef, xxs) -> pr2 ("stmt_elems_of_sequencable: IfdefStm2 TODO?"); @@ -955,6 +989,8 @@ let rec stmt_elems_of_sequencable xs = +(* should maybe be in pretty_print_c ? *) + let s_of_inc_file inc_file = match inc_file with | Local xs -> xs +> Common.join "/" @@ -972,3 +1008,9 @@ let fieldname_of_fieldkind fieldkind = | Simple (sopt, ft) -> sopt | BitField (sopt, ft, expr) -> sopt + +let s_of_attr attr = + attr + +> List.map (fun (Attribute s, ii) -> s) + +> Common.join "," + diff --git a/parsing_c/ast_to_flow.ml b/parsing_c/ast_to_flow.ml index 3a12704..5f6e930 100644 --- a/parsing_c/ast_to_flow.ml +++ b/parsing_c/ast_to_flow.ml @@ -40,6 +40,7 @@ type error = | DuplicatedLabel of string | NestedFunc | ComputedGoto + | Define of Common.parse_info exception Error of error @@ -972,7 +973,7 @@ and aux_statement_list starti (xi, newxi) statxs = elsei ) in - let finalxs = + let _finalxs = Common.zip (newi::elsenodes) xxs +> List.map (fun (start_nodei, xs)-> let finalthen = aux_statement_list (Some start_nodei) (newxi, newxi) xs in @@ -997,6 +998,7 @@ let (aux_definition: nodei -> definition -> unit) = fun topi funcdef -> f_storage= sto; f_body= compound; f_attr= attrs; + f_old_c_style = oldstyle; }, ii) = funcdef in let iifunheader, iicompound = (match ii with @@ -1015,7 +1017,8 @@ let (aux_definition: nodei -> definition -> unit) = fun topi funcdef -> f_type = functype; f_storage = sto; f_attr = attrs; - f_body = [] (* empty body *) + f_body = [] (* empty body *); + f_old_c_style = oldstyle; }, iifunheader)) lbl_start ("function " ^ funcs) in let enteri = !g +> add_node Enter lbl_0 "[enter]" in @@ -1155,15 +1158,15 @@ let ast_to_control_flow e = | Ast_c.DefineFunction def -> aux_definition headeri def; - | Ast_c.DefineText (s, ii) -> - raise Todo + | Ast_c.DefineText (s, s_ii) -> + raise (Error(Define(pinfo_of_ii ii))) | Ast_c.DefineEmpty -> let endi = !g +> add_node EndNode lbl_0 "[end]" in !g#add_arc ((headeri, endi),Direct); | Ast_c.DefineInit _ -> - raise Todo + raise (Error(Define(pinfo_of_ii ii))) | Ast_c.DefineTodo -> - raise Todo + raise (Error(Define(pinfo_of_ii ii))) ); Some !g @@ -1347,3 +1350,5 @@ let report_error error = pr2 ("FLOW: not handling yet nested function") | ComputedGoto -> pr2 ("FLOW: not handling computed goto yet") + | Define info -> + pr2 ("Unsupported form of #define: " ^ error_from_info info) diff --git a/parsing_c/ast_to_flow.mli b/parsing_c/ast_to_flow.mli index 56d6109..52b2ffa 100644 --- a/parsing_c/ast_to_flow.mli +++ b/parsing_c/ast_to_flow.mli @@ -16,6 +16,7 @@ type error = | DuplicatedLabel of string | NestedFunc | ComputedGoto + | Define of Common.parse_info exception Error of error diff --git a/parsing_c/cpp_ast_c.ml b/parsing_c/cpp_ast_c.ml index df0718b..9633b4f 100644 --- a/parsing_c/cpp_ast_c.ml +++ b/parsing_c/cpp_ast_c.ml @@ -9,10 +9,11 @@ open Ast_c (* * cpp-include-expander-builtin. * - * alternative1: parse and call cpp tour a tour ? + * alternative1: parse and call cpp tour a tour. So let cpp work at + * the token level. That's what most tools do. * alternative2: apply cpp at the very end. Process that go through ast - * and do the stuff such as #include, macro expand, - * ifdef. + * and do the stuff such as #include, macro expand, + * ifdef but on the ast! * * But need keep those info in ast at least, even bad * macro for instance, and for parse error region ? maybe can @@ -35,6 +36,8 @@ open Ast_c * ??add such info about what was done somewhere ? could build new * ??ast each time but too tedious (maybe need delta-programming!) * + * todo? maybe change cpp_ast_c to go deeper on local "" ? + * * * TODO: macro expand, * TODO: handle ifdef @@ -53,7 +56,7 @@ open Ast_c (*****************************************************************************) type cpp_option = - | I of Common.filename + | I of Common.dirname | D of string * string option @@ -79,8 +82,23 @@ let cpp_option_of_cmdline (xs, ys) = (* Helpers *) (*****************************************************************************) +let _hcandidates = Hashtbl.create 101 + +let init_adjust_candidate_header_files dir = + let ext = "[h]" in + let files = Common.files_of_dir_or_files ext [dir] in + + files +> List.iter (fun file -> + let base = Filename.basename file in + pr2 file; + Hashtbl.add _hcandidates base file; + ); + () + + + (* may return a list of match ? *) -let find_header_file cppopts dirname inc_file = +let find_header_file1 cppopts dirname inc_file = match inc_file with | Local f -> let finalfile = @@ -100,7 +118,40 @@ let find_header_file cppopts dirname inc_file = pr2 ("CPPAST: wierd include not handled:" ^ s); [] +(* todo? can try find most precise ? first just use basename but + * then maybe look if have also some dir in common ? + *) +let find_header_file2 inc_file = + match inc_file with + | Local f + | NonLocal f -> + let s = (Ast_c.s_of_inc_file inc_file) in + let base = Filename.basename s in + + let res = Hashtbl.find_all _hcandidates base in + (match res with + | [file] -> + pr2 ("CPPAST: find header in other dir: " ^ file); + res + | [] -> + [] + | x::y::xs -> res + ) + | Wierd s -> + [] + + +let find_header_file cppopts dirname inc_file = + let res1 = find_header_file1 cppopts dirname inc_file in + match res1 with + | [file] -> res1 + | [] -> find_header_file2 inc_file + | x::y::xs -> res1 + + + +(* ---------------------------------------------------------------------- *) let trace_cpp_process depth mark inc_file = pr2 (spf "%s>%s %s" (Common.repeat "-" depth +> Common.join "") @@ -109,14 +160,53 @@ let trace_cpp_process depth mark inc_file = () +(* ---------------------------------------------------------------------- *) +let _headers_hash = Hashtbl.create 101 + +(* On freebsd ocaml is trashing, use up to 1.6Go of memory and then + * building the database_c takes ages. + * + * So just limit with following threshold to avoid this trashing, simple. + * + * On netbsd, got a Out_of_memory exn on this file; + * /home/pad/software-os-src2/netbsd/dev/microcode/cyclades-z/ + * even if the cache is small. That's because huge single + * ast element and probably the ast marshalling fail. + *) +let threshold_cache_nb_files = ref 200 + +let parse_c_and_cpp_cache file = + if Hashtbl.length _headers_hash > !threshold_cache_nb_files + then Hashtbl.clear _headers_hash; + + Common.memoized _headers_hash file (fun () -> + Parse_c.parse_c_and_cpp file + ) + + +(* ---------------------------------------------------------------------- *) +let (show_cpp_i_opts: string list -> unit) = fun xs -> + if not (null xs) then begin + pr2 "-I"; + xs +> List.iter pr2 + end + + +let (show_cpp_d_opts: string list -> unit) = fun xs -> + if not (null xs) then begin + pr2 "-D"; + xs +> List.iter pr2 + end + (*****************************************************************************) (* Main entry *) (*****************************************************************************) -let (cpp_expand_include: +let (cpp_expand_include2: + ?depth_limit:int option -> cpp_option list -> Common.dirname -> Ast_c.program -> Ast_c.program) = - fun iops dirname ast -> + fun ?(depth_limit=None) iops dirname ast -> pr2_xxxxxxxxxxxxxxxxx(); let already_included = ref [] in @@ -133,6 +223,10 @@ let (cpp_expand_include: i_content = copt; } -> + (match depth_limit with + | Some limit when depth >= limit -> cpp + | _ -> + (match find_header_file iops dirname inc_file with | [file] -> if List.mem file !already_included @@ -146,7 +240,7 @@ let (cpp_expand_include: (* CONFIG *) Flag_parsing_c.verbose_parsing := false; Flag_parsing_c.verbose_lexing := false; - let (ast2, _stat) = Parse_c.parse_c_and_cpp file in + let (ast2, _stat) = parse_c_and_cpp_cache file in let ast = Parse_c.program_of_program2 ast2 in let dirname' = Filename.dirname file in @@ -169,6 +263,7 @@ let (cpp_expand_include: pr2 "CPPAST: too much candidates"; k cpp ) + ) | _ -> k cpp ); } @@ -176,6 +271,9 @@ let (cpp_expand_include: aux [] dirname ast +let cpp_expand_include ?depth_limit a b c = + Common.profile_code "cpp_expand_include" + (fun () -> cpp_expand_include2 ?depth_limit a b c) (* let unparse_showing_include_content ? @@ -275,3 +373,14 @@ let rec cpp_ifdef_statementize ast = aux xs ); } ast + + +(*****************************************************************************) +(* Macro *) +(*****************************************************************************) + +let (cpp_expand_macro_expr: + Ast_c.define_kind -> Ast_c.argument Ast_c.wrap2 list -> + Ast_c.expression option) = + fun defkind args -> + raise Todo diff --git a/parsing_c/cpp_ast_c.mli b/parsing_c/cpp_ast_c.mli index 401fe1b..713bd5e 100644 --- a/parsing_c/cpp_ast_c.mli +++ b/parsing_c/cpp_ast_c.mli @@ -1,14 +1,41 @@ type cpp_option = - | I of Common.filename + | I of Common.dirname | D of string * string option val cpp_option_of_cmdline: Common.dirname list (* -I *) * string list (* -D *) -> cpp_option list +val show_cpp_i_opts: string list -> unit +val show_cpp_d_opts: string list -> unit + +(* ---------------------------------------------------------------------- *) +(* cpp_expand_include below internally use cache of header file to + * speedup as reinclude very often the same basic header file. But that + * means that the asts of those headers are then shared so take + * care. +*) +val _headers_hash: + (Common.filename, Parse_c.program2 * Parsing_stat.parsing_stat) Hashtbl.t +val threshold_cache_nb_files: int ref + +(* It can also try to find header files in nested directories if the + * caller use the function below first. + *) +val init_adjust_candidate_header_files: Common.dirname -> unit + +(* ---------------------------------------------------------------------- *) + +(* include *) val cpp_expand_include: - cpp_option list -> Common.dirname (* start point for relative paths *) -> + ?depth_limit:int option -> cpp_option list -> + Common.dirname (* start point for relative paths *) -> Ast_c.program -> Ast_c.program - +(* ifdef *) val cpp_ifdef_statementize: Ast_c.program -> Ast_c.program +(* define *) +val cpp_expand_macro_expr: + Ast_c.define_kind -> Ast_c.argument Ast_c.wrap2 list -> + Ast_c.expression option + diff --git a/parsing_c/flag_parsing_c.ml b/parsing_c/flag_parsing_c.ml index 049e3ff..2a01793 100644 --- a/parsing_c/flag_parsing_c.ml +++ b/parsing_c/flag_parsing_c.ml @@ -29,6 +29,18 @@ let cmdline_flags_cpp () = [ " " ] +(*****************************************************************************) +(* types *) +(*****************************************************************************) +let std_envir = ref (Filename.concat !path "config/envos/environment_splint.h") + +let cmdline_flags_envfile () = + [ + "-env_file", Arg.Set_string std_envir, + " (default=" ^ !std_envir ^ ")"; + ] + + (*****************************************************************************) (* verbose *) (*****************************************************************************) @@ -36,6 +48,7 @@ let cmdline_flags_cpp () = [ let verbose_lexing = ref true let verbose_parsing = ref true let verbose_type = ref true +let verbose_annotater = ref true let filter_msg = ref false let filter_msg_define_error = ref false @@ -52,9 +65,11 @@ let show_flow_labels = ref true let cmdline_flags_verbose () = [ - "-no_parse_error_msg", Arg.Clear verbose_parsing, " "; "-no_verbose_parsing", Arg.Clear verbose_parsing , " "; "-no_verbose_lexing", Arg.Clear verbose_lexing , " "; + "-no_verbose_annotater", Arg.Clear verbose_annotater , " "; + + "-no_parse_error_msg", Arg.Clear verbose_parsing, " "; "-no_type_error_msg", Arg.Clear verbose_type, " "; @@ -94,6 +109,17 @@ let cmdline_flags_debugging () = "-debug_unparsing", Arg.Set debug_unparsing, " "; ] +(*****************************************************************************) +(* checks *) +(*****************************************************************************) + +let check_annotater = ref true +let cmdline_flags_checks () = + [ + "-disable_check_annotater", Arg.Clear check_annotater, " "; + "-enable_check_annotater", Arg.Set check_annotater, " "; + ] + (*****************************************************************************) (* change algo *) (*****************************************************************************) @@ -153,6 +179,4 @@ let cmdline_flags_other () = " use .ast_raw pre-parsed cached C file"; ] - (*****************************************************************************) - diff --git a/parsing_c/lexer_c.mll b/parsing_c/lexer_c.mll index 5dd00d7..531b582 100644 --- a/parsing_c/lexer_c.mll +++ b/parsing_c/lexer_c.mll @@ -619,6 +619,8 @@ rule token = parse (* Take care of the order ? No because lex try the longest match. The * strange diff between decimal and octal constant semantic is not * understood too by refman :) refman:11.1.4, and ritchie. + * + * todo: attach type info to constant, like for float *) | (( decimal | hexa | octal) diff --git a/parsing_c/lexer_parser.ml b/parsing_c/lexer_parser.ml index cf18a58..7465bab 100644 --- a/parsing_c/lexer_parser.ml +++ b/parsing_c/lexer_parser.ml @@ -94,6 +94,9 @@ type context = | InParameter | InInitializer | InEnum +(* InExpr ? but then orthogonal to InFunction. Could assign InExpr for + * instance after a '=' as in 'a = (irq_t) b;' + *) let is_top_or_struct = function | InTopLevel diff --git a/parsing_c/lib_parsing_c.ml b/parsing_c/lib_parsing_c.ml index fd87d49..bddf492 100644 --- a/parsing_c/lib_parsing_c.ml +++ b/parsing_c/lib_parsing_c.ml @@ -53,8 +53,17 @@ let al_type x = Visitor_c.vk_type_s (strip_info_visitor()) x let al_param x = Visitor_c.vk_param_s (strip_info_visitor()) x let al_params x = Visitor_c.vk_params_s (strip_info_visitor()) x let al_arguments x = Visitor_c.vk_arguments_s (strip_info_visitor()) x +let al_fields x = Visitor_c.vk_struct_fields_s (strip_info_visitor()) x + +let al_node x = Visitor_c.vk_node_s (strip_info_visitor()) x let al_program x = List.map (Visitor_c.vk_toplevel_s (strip_info_visitor())) x +let al_ii x = Visitor_c.vk_ii_s (strip_info_visitor()) x + + + + + let semi_strip_info_visitor = (* keep position information *) { Visitor_c.default_visitor_c_s with @@ -76,6 +85,39 @@ let semi_al_arguments = Visitor_c.vk_arguments_s semi_strip_info_visitor let semi_al_program = List.map (Visitor_c.vk_toplevel_s semi_strip_info_visitor) + + + + +let real_strip_info_visitor _ = + { Visitor_c.default_visitor_c_s with + Visitor_c.kinfo_s = (fun (k,_) i -> + Ast_c.real_al_info i + ); + + Visitor_c.kexpr_s = (fun (k,_) e -> + let (e', ty),ii' = k e in + (e', Ast_c.noType()), ii' + ); + +(* + Visitor_c.ktype_s = (fun (k,_) ft -> + let ft' = k ft in + match Ast_c.unwrap_typeC ft' with + | Ast_c.TypeName (s,_typ) -> + Ast_c.TypeName (s, Ast_c.noTypedefDef()) +> Ast_c.rewrap_typeC ft' + | _ -> ft' + + ); +*) + + } + +let real_al_expr x = Visitor_c.vk_expr_s (real_strip_info_visitor()) x +let real_al_node x = Visitor_c.vk_node_s (real_strip_info_visitor()) x +let real_al_type x = Visitor_c.vk_type_s (real_strip_info_visitor()) x + + (*****************************************************************************) (* Extract infos *) (*****************************************************************************) @@ -109,6 +151,8 @@ let ii_of_define_params = extract_info_visitor Visitor_c.vk_define_params_splitted let ii_of_toplevel = extract_info_visitor Visitor_c.vk_toplevel +(*****************************************************************************) +(* Max min, range *) (*****************************************************************************) let max_min_ii_by_pos xs = match xs with @@ -144,3 +188,24 @@ let lin_col_by_pos xs = (Ast_c.line_of_info i1, posf i1), (Ast_c.line_of_info i2, mposf i2)) + + + +let min_pinfo_of_node node = + let ii = ii_of_node node in + let (maxii, minii) = max_min_ii_by_pos ii in + Ast_c.parse_info_of_info minii + + +let (range_of_origin_ii: Ast_c.info list -> (int * int) option) = + fun ii -> + let ii = List.filter Ast_c.is_origintok ii in + try + let (max, min) = max_min_ii_by_pos ii in + assert(Ast_c.is_origintok max); + assert(Ast_c.is_origintok min); + let strmax = Ast_c.str_of_info max in + Some + (Ast_c.pos_of_info min, Ast_c.pos_of_info max + String.length strmax) + with _ -> + None diff --git a/parsing_c/parse_c.ml b/parsing_c/parse_c.ml index 00c62f7..c00b746 100644 --- a/parsing_c/parse_c.ml +++ b/parsing_c/parse_c.ml @@ -68,8 +68,10 @@ let mk_info_item2 filename toks = begin toks +> List.iter (fun tok -> match TH.pinfo_of_tok tok with - | Ast_c.OriginTok _ -> Buffer.add_string buf (TH.str_of_tok tok) - | Ast_c.AbstractLineTok _ -> raise Impossible + | Ast_c.OriginTok _ -> + Buffer.add_string buf (TH.str_of_tok tok) + | Ast_c.AbstractLineTok _ -> + raise Impossible | _ -> () ); Buffer.contents buf @@ -82,6 +84,8 @@ let mk_info_item a b = (fun () -> mk_info_item2 a b) +let info_same_line line xs = + xs +> List.filter (fun info -> Ast_c.line_of_info info = line) (*****************************************************************************) @@ -976,7 +980,7 @@ let get_one_elem ~pass tr (file, filelines) = let info_of_bads = Common.map_eff_rev TH.info_of_tok tr.passed in - Right (info_of_bads, line_error) + Right (info_of_bads, line_error, tr.passed) end ) @@ -997,7 +1001,7 @@ let get_one_elem ~pass tr (file, filelines) = let parse_print_error_heuristic2 file = - let filelines = (""::Common.cat file) +> Array.of_list in + let filelines = Common.cat_array file in let stat = Parsing_stat.default_stat file in (* -------------------------------------------------- *) @@ -1062,7 +1066,7 @@ let parse_print_error_heuristic2 file = let was_define = (match elem with | Left _ -> false - | Right (_, line_error) -> + | Right (_, line_error, _) -> let was_define = let xs = tr.passed +> List.rev +> List.filter TH.is_not_comment in if List.length xs >= 2 @@ -1108,17 +1112,27 @@ let parse_print_error_heuristic2 file = let elem = match elem with - | Left e -> e - | Right (info_of_bads, _line_error) -> + | Left e -> + stat.Stat.correct <- stat.Stat.correct + diffline; + e + | Right (info_of_bads, line_error, toks_of_bads) -> + if was_define && !Flag_parsing_c.filter_define_error + then stat.Stat.correct <- stat.Stat.correct + diffline + else stat.Stat.bad <- stat.Stat.bad + diffline; + + let pbline = + toks_of_bads + +> Common.filter (TH.is_same_line line_error) + +> Common.filter TH.is_ident_like + in + let error_info = + (pbline +> List.map TH.str_of_tok), line_error + in + stat.Stat.problematic_lines <- + error_info::stat.Stat.problematic_lines; + Ast_c.NotParsedCorrectly info_of_bads in - (match elem with - | Ast_c.NotParsedCorrectly xs -> - if was_define && !Flag_parsing_c.filter_define_error - then stat.Stat.correct <- stat.Stat.correct + diffline - else stat.Stat.bad <- stat.Stat.bad + diffline - | _ -> stat.Stat.correct <- stat.Stat.correct + diffline - ); (match elem with | Ast_c.FinalDef x -> [(Ast_c.FinalDef x, info)] @@ -1126,7 +1140,6 @@ let parse_print_error_heuristic2 file = ) in let v = loop tr in - let v = consistency_checking v in (v, stat) diff --git a/parsing_c/parse_c.mli b/parsing_c/parse_c.mli index 2287d7a..8a6cc91 100644 --- a/parsing_c/parse_c.mli +++ b/parsing_c/parse_c.mli @@ -53,6 +53,7 @@ val parse_gen: *) val type_of_string : string -> Ast_c.fullType val statement_of_string : string -> Ast_c.statement + (* similar but use parse_c_and_cpp and a /tmp/__cocci.c and extract the part *) val cstatement_of_string : string -> Ast_c.statement val cexpression_of_string : string -> Ast_c.expression @@ -62,9 +63,10 @@ val cexpression_of_string : string -> Ast_c.expression (* ---------------------------------------------------------------------- *) (* a few helpers *) +val print_commentized : Parser_c.token list -> unit + val program_of_program2 : program2 -> Ast_c.program val with_program2: (Ast_c.program -> Ast_c.program) -> program2 -> program2 -val print_commentized : Parser_c.token list -> unit diff --git a/parsing_c/parser_c.mly b/parsing_c/parser_c.mly index a14d178..4ab8457 100644 --- a/parsing_c/parser_c.mly +++ b/parsing_c/parser_c.mly @@ -111,7 +111,8 @@ let addQualif = function | ({volatile=true},({volatile=true} as x))-> warning "duplicate 'volatile'" x | ({const=true}, v) -> {v with const=true} | ({volatile=true}, v) -> {v with volatile=true} - | _ -> internal_error "there is no noconst or novolatile keyword" + | _ -> + internal_error "there is no noconst or novolatile keyword" let addQualifD ((qu,ii), ({qualifD = (v,ii2)} as x)) = { x with qualifD = (addQualif (qu, v),ii::ii2) } @@ -135,7 +136,11 @@ let (fixDeclSpecForDecl: decl -> (fullType * (storage wrap))) = function ( ((qu, iiq), (match ty with - | (None,None,None) -> warning "type defaults to 'int'" (defaultInt, []) + | (None,None,None) -> + (* generate fake_info, otherwise type_annotater can crash in + * offset. + *) + warning "type defaults to 'int'" (defaultInt, [fakeInfo fake_pi]) | (None, None, Some t) -> (t, iit) | (Some sign, None, (None| Some (BaseType (IntType (Si (_,CInt)))))) -> @@ -225,15 +230,14 @@ let (fixOldCDecl: fullType -> fullType) = fun ty -> raise (Semantic ("seems this is not a function", fake_pi)) -let fixFunc = function - | (( - (s,iis), - (nQ, (FunctionType (fullt, (params,bool)),iifunc)), - (st,iist), - attrs - ), - (cp,iicp) - ) +let fixFunc (typ, compound, old_style_opt) = + let (cp,iicp) = compound in + + match typ with + | ((s,iis), + (nQ, (FunctionType (fullt, (params,bool)),iifunc)), + (st,iist), + attrs) -> let iistart = Ast_c.fakeInfo () in assert (nQ =*= nullQualif); @@ -251,6 +255,7 @@ let fixFunc = function f_storage = st; f_body = cp; f_attr = attrs; + f_old_c_style = old_style_opt; }, ([iis]++iifunc++iicp++[iistart]++iist) | _ -> @@ -936,7 +941,8 @@ attribute_storage: type_qualif_attr: | type_qualif { $1 } - | TMacroAttr { {const=false ; volatile=false}, snd $1 (*TODO*) } +/*(*TODO !!!!! *)*/ + | TMacroAttr { {const=true ; volatile=false}, snd $1 } /*(*-----------------------------------------------------------------------*)*/ /*(* Declarator, right part of a type + second part of decl (the ident) *)*/ @@ -1423,16 +1429,15 @@ idente: ident { LP.add_ident (fst $1); $1 } function_definition: function_def { fixFunc $1 } decl_list: - | decl { [$1] } - | decl_list decl { $1 ++ [$2] } + | decl { [$1 Ast_c.LocalDecl] } + | decl_list decl { $1 ++ [$2 Ast_c.LocalDecl] } function_def: - | start_fun compound { LP.del_scope(); ($1, $2) } + | start_fun compound { LP.del_scope(); ($1, $2, None) } | start_fun decl_list compound { - pr2 "OLD STYLE DECL NOT WELL SUPPORTED"; (* TODO: undo the typedef added ? *) LP.del_scope(); - ($1, $3) + ($1, $3, Some $2) } start_fun: start_fun2 diff --git a/parsing_c/parsing_hacks.ml b/parsing_c/parsing_hacks.ml index fcca15a..e7ed48a 100644 --- a/parsing_c/parsing_hacks.ml +++ b/parsing_c/parsing_hacks.ml @@ -2405,7 +2405,10 @@ let lookahead2 ~pass next before = TypedefIdent (s, i1) - (* (xx) ( yy) *) + (* (xx) ( yy) + * but false positif: typedef int (xxx_t)(...), so do specialisation below. + *) + (* | (TIdent (s, i1)::TCPar _::TOPar _::_ , (TOPar info)::x::_) when not (TH.is_stuff_taking_parenthized x) && ok_typedef s @@ -2413,6 +2416,16 @@ let lookahead2 ~pass next before = msg_typedef s; LP.add_typedef_root s; (* TOPar info *) TypedefIdent (s, i1) + *) + (* special case: = (xx) ( yy) *) + | (TIdent (s, i1)::TCPar _::TOPar _::_ , + (TOPar info)::(TEq _ |TEqEq _)::_) + when ok_typedef s + -> + msg_typedef s; LP.add_typedef_root s; + (* TOPar info *) + TypedefIdent (s, i1) + (* (xx * ) yy *) | (TIdent (s, i1)::TMul _::TCPar _::TIdent (s2, i2)::_ , (TOPar info)::_) when @@ -2438,7 +2451,10 @@ let lookahead2 ~pass next before = LP.add_typedef_root s; Tsizeof *) - (* x ( *y )(params), function pointer *) + + + (* ----------------------------------- *) + (* x ( *y )(params), function pointer *) | (TIdent (s, i1)::TOPar _::TMul _::TIdent _::TCPar _::TOPar _::_, _) when not_struct_enum before && ok_typedef s @@ -2446,6 +2462,14 @@ let lookahead2 ~pass next before = msg_typedef s; LP.add_typedef_root s; TypedefIdent (s, i1) + (* x* ( *y )(params), function pointer 2 *) + | (TIdent (s, i1)::TMul _::TOPar _::TMul _::TIdent _::TCPar _::TOPar _::_, _) + when not_struct_enum before + && ok_typedef s + -> + msg_typedef s; LP.add_typedef_root s; + TypedefIdent (s, i1) + (*-------------------------------------------------------------*) (* CPP *) diff --git a/parsing_c/parsing_hacks.mli b/parsing_c/parsing_hacks.mli index dbf050f..e18a461 100644 --- a/parsing_c/parsing_hacks.mli +++ b/parsing_c/parsing_hacks.mli @@ -1,8 +1,9 @@ open Common -(* Try detect some cpp idioms so can parse as-is files by adjusting or - * commenting some tokens. Parsing hack style. Sometime use indentation info, - * sometimes do some kind of lalr(k) by finding patterns. Often try to +(* This module tries to detect some cpp idioms so that we can parse as-is + * files by adjusting or commenting some tokens. Parsing hack style. + * Sometime we use some indentation information, + * sometimes we do some kind of lalr(k) by finding patterns. Often try to * work on better token representation, like ifdef-paren-ized, brace-ized, * paren-ized, so can do easier pattern matching to more easily match * complex cpp idiom pattern. Also try to get context info such as @@ -23,6 +24,7 @@ open Common * - macro no ptvirg * - macro string, and macro function string taking param and ## * - macro attribute + * * Cf the TMacroXxx in parser_c.mly and MacroXxx in ast_c.ml * * Also try infer typedef. @@ -51,6 +53,12 @@ type define_def = string * define_param * define_body | HintMacroStatement | HintAttribute +val regexp_macro: Str.regexp +val regexp_annot: Str.regexp +val regexp_declare: Str.regexp +val regexp_foreach: Str.regexp +val regexp_typedef: Str.regexp + val _defs : (string, define_def) Hashtbl.t ref (* can reset it *) @@ -67,3 +75,4 @@ val lookahead : pass:int -> Parser_c.token list -> Parser_c.token list -> Parser_c.token + diff --git a/parsing_c/parsing_stat.ml b/parsing_c/parsing_stat.ml index a5cb607..c7224ca 100644 --- a/parsing_c/parsing_stat.ml +++ b/parsing_c/parsing_stat.ml @@ -25,6 +25,9 @@ type parsing_stat = { * function to end of function. *) + mutable problematic_lines: + (string list (* ident in error line *) * int (* line_error *)) list; + } let default_stat file = { @@ -32,6 +35,7 @@ let default_stat file = { have_timeout = false; correct = 0; bad = 0; commentized = 0; + problematic_lines = []; } (* todo: stat per dir ? give in terms of func_or_decl numbers: @@ -108,11 +112,63 @@ let print_parsing_stat_list ?(verbose=false) = fun statxs -> ) ) +(*****************************************************************************) +(* Recurring error diagnostic *) +(*****************************************************************************) +(* asked/inspired by reviewer of CC'09 *) + +let lines_around_error_line ~context (file, line) = + let arr = Common.cat_array file in + + let startl = max 0 (line - context) in + let endl = min (Array.length arr) (line + context) in + let res = ref [] in + + for i = startl to endl do + Common.push2 arr.(i) res + done; + List.rev !res + + + +let print_recurring_problematic_tokens xs = + let h = Hashtbl.create 101 in + xs +> List.iter (fun x -> + let file = x.filename in + x.problematic_lines +> List.iter (fun (xs, line_error) -> + xs +> List.iter (fun s -> + Common.hupdate_default s + (fun (old, example) -> old + 1, example) + (fun() -> 0, (file, line_error)) h; + ))); + pr2_xxxxxxxxxxxxxxxxx(); + pr2 ("maybe 10 most problematic tokens"); + pr2_xxxxxxxxxxxxxxxxx(); + Common.hash_to_list h + +> List.sort (fun (k1,(v1,_)) (k2,(v2,_)) -> compare v2 v1) + +> Common.take_safe 10 + +> List.iter (fun (k,(i, (file_ex, line_ex))) -> + pr2 (spf "%s: present in %d parsing errors" k i); + pr2 ("example: "); + let lines = lines_around_error_line ~context:2 (file_ex, line_ex) in + lines +> List.iter (fun s -> pr2 (" " ^ s)); + + ); + pr2_xxxxxxxxxxxxxxxxx(); + () + + + + (*****************************************************************************) (* Stat *) (*****************************************************************************) -(* coupling: if you add a new var, modify also assoc_stat_number below *) +(* Those variables were written for CC09, to evaluate the need for + * some of our heuristics and extensions. + * + * coupling: if you add a new var, modify also assoc_stat_number below + *) let nTypedefInfer = ref 0 diff --git a/parsing_c/pretty_print_c.ml b/parsing_c/pretty_print_c.ml index 0c8bef0..edbe3b3 100644 --- a/parsing_c/pretty_print_c.ml +++ b/parsing_c/pretty_print_c.ml @@ -1076,17 +1076,17 @@ let pp_flow_gen pr_elem pr_space n = pr2 "Def"; - | F.Decl decl -> + | F.Decl decl -> (* vk_decl bigf decl *) pr2 "Decl" - | F.ExprStatement (st, (eopt, ii)) -> + | F.ExprStatement (st, (eopt, ii)) -> pp_statement_gen pr_elem pr_space (ExprStatement eopt, ii) - | F.IfHeader (_, (e,ii)) - | F.SwitchHeader (_, (e,ii)) - | F.WhileHeader (_, (e,ii)) - | F.DoWhileTail (e,ii) -> + | F.IfHeader (_, (e,ii)) + | F.SwitchHeader (_, (e,ii)) + | F.WhileHeader (_, (e,ii)) + | F.DoWhileTail (e,ii) -> (* iif ii; vk_expr bigf e @@ -1094,7 +1094,7 @@ let pp_flow_gen pr_elem pr_space n = pr2 "XXX"; - | F.ForHeader (_st, (((e1opt,i1), (e2opt,i2), (e3opt,i3)), ii)) -> + | F.ForHeader (_st, (((e1opt,i1), (e2opt,i2), (e3opt,i3)), ii)) -> (* iif i1; iif i2; iif i3; iif ii; @@ -1104,7 +1104,7 @@ let pp_flow_gen pr_elem pr_space n = *) pr2 "XXX"; - | F.MacroIterHeader (_s, ((s,es), ii)) -> + | F.MacroIterHeader (_s, ((s,es), ii)) -> (* iif ii; vk_argument_list bigf es; @@ -1112,32 +1112,32 @@ let pp_flow_gen pr_elem pr_space n = pr2 "XXX"; - | F.ReturnExpr (_st, (e,ii)) -> + | F.ReturnExpr (_st, (e,ii)) -> (* iif ii; vk_expr bigf e*) pr2 "XXX"; - | F.Case (_st, (e,ii)) -> - (* iif ii; vk_expr bigf e *) + | F.Case (_st, (e,ii)) -> + (* iif ii; vk_expr bigf e *) pr2 "XXX"; - - | F.CaseRange (_st, ((e1, e2),ii)) -> + + | F.CaseRange (_st, ((e1, e2),ii)) -> (* iif ii; vk_expr bigf e1; vk_expr bigf e2 *) pr2 "XXX"; - | F.CaseNode i -> () + | F.CaseNode i -> () - | F.DefineExpr e -> + | F.DefineExpr e -> (* vk_expr bigf e *) pr2 "XXX"; - | F.DefineType ft -> + | F.DefineType ft -> (* vk_type bigf ft *) pr2 "XXX"; - | F.DefineHeader ((s,ii), (defkind)) -> + | F.DefineHeader ((s,ii), (defkind)) -> (* iif ii; vk_define_kind bigf defkind; @@ -1145,17 +1145,17 @@ let pp_flow_gen pr_elem pr_space n = pr2 "XXX"; - | F.DefineDoWhileZeroHeader (((),ii)) -> + | F.DefineDoWhileZeroHeader (((),ii)) -> (* iif ii *) pr2 "XXX"; - | F.Include {i_include = (s, ii);} -> + | F.Include {i_include = (s, ii);} -> (* iif ii; *) pr2 "XXX"; - | F.MacroTop (s, args, ii) -> + | F.MacroTop (s, args, ii) -> (* iif ii; vk_argument_list bigf args *) pr2 "XXX"; @@ -1213,6 +1213,9 @@ let pp_flow_gen pr_elem pr_space n = | F.IfdefEndif (info) -> pp_ifdef_gen pr_elem pr_space info + | F.DefineTodo -> + pr2 "XXX"; + | ( F.TopNode|F.EndNode| @@ -1244,3 +1247,18 @@ let pp_type_simple = pp_type_gen pr_elem pr_space let pp_toplevel_simple = pp_program_gen pr_elem pr_space let pp_flow_simple = pp_flow_gen pr_elem pr_space + + +let string_of_expression e = + Common.format_to_string (fun () -> + pp_expression_simple e + ) + +let (debug_info_of_node: Ograph_extended.nodei -> Control_flow_c.cflow -> string) = + fun nodei flow -> + let node = flow#nodes#assoc nodei in + let s = Common.format_to_string (fun () -> + pp_flow_simple node + ) in + let pos = Lib_parsing_c.min_pinfo_of_node node in + (spf "%s(n%d)--> %s" (Common.string_of_parse_info_bis pos) nodei s) diff --git a/parsing_c/pretty_print_c.mli b/parsing_c/pretty_print_c.mli index c78de1a..76c5dca 100644 --- a/parsing_c/pretty_print_c.mli +++ b/parsing_c/pretty_print_c.mli @@ -24,3 +24,8 @@ val pp_statement_simple : Ast_c.statement -> unit val pp_type_simple : Ast_c.fullType -> unit val pp_toplevel_simple : Ast_c.toplevel -> unit val pp_flow_simple: Control_flow_c.node -> unit + + +val debug_info_of_node: Ograph_extended.nodei -> Control_flow_c.cflow -> string + +val string_of_expression: Ast_c.expression -> string diff --git a/parsing_c/test_parsing_c.ml b/parsing_c/test_parsing_c.ml index 868c537..c788da0 100644 --- a/parsing_c/test_parsing_c.ml +++ b/parsing_c/test_parsing_c.ml @@ -1,9 +1,12 @@ open Common +open Ast_c + let score_path = "/home/pad/c-yacfe/tmp" let tmpfile = "/tmp/output.c" + (*****************************************************************************) (* Subsystem testing *) (*****************************************************************************) @@ -70,12 +73,15 @@ let test_parse_gen xs ext = ); if not (null !stat_list) - then Parsing_stat.print_parsing_stat_list !stat_list; + then begin + Parsing_stat.print_recurring_problematic_tokens !stat_list; + Parsing_stat.print_parsing_stat_list !stat_list; + end; dirname_opt +> Common.do_option (fun dirname -> - pr2 "--------------------------------"; + pr2_xxxxxxxxxxxxxxxxx(); pr2 "regression testing information"; - pr2 "--------------------------------"; + pr2_xxxxxxxxxxxxxxxxx(); let str = Str.global_replace (Str.regexp "/") "__" dirname in let def = if !Flag_parsing_c.filter_define_error then "_def_" else "" in let ext = if ext = "c" then "" else ext in @@ -155,6 +161,24 @@ let test_cfg file = +let test_cfg_ifdef file = + let (ast2, _stat) = Parse_c.parse_print_error_heuristic file in + let ast = Parse_c.program_of_program2 ast2 in + + let ast = Cpp_ast_c.cpp_ifdef_statementize ast in + + ast +> List.iter (fun e -> + (try + let flow = Ast_to_flow.ast_to_control_flow e in + flow +> do_option (fun flow -> + Ast_to_flow.deadcode_detection flow; + let flow = Ast_to_flow.annotate_loop_nodes flow in + Ograph_extended.print_ograph_mutable flow ("/tmp/output.dot") true + ) + with Ast_to_flow.Error (x) -> Ast_to_flow.report_error x + ) + ) + (* ---------------------------------------------------------------------- *) let test_parse_unparse infile = if not (infile =~ ".*\\.c") @@ -185,7 +209,7 @@ let test_type_c infile = program2 +> Common.unzip +> (fun (program, infos) -> - Type_annoter_c.annotate_program Type_annoter_c.initial_env true + Type_annoter_c.annotate_program !Type_annoter_c.initial_env program +> List.map fst, infos ) @@ -222,6 +246,53 @@ let test_compare_c_hardcoded () = +(* ---------------------------------------------------------------------- *) +let test_attributes file = + let (ast2, _stat) = Parse_c.parse_c_and_cpp file in + let ast = Parse_c.program_of_program2 ast2 in + + Visitor_c.vk_program { Visitor_c.default_visitor_c with + Visitor_c.kdef = (fun (k, bigf) (defbis, ii) -> + let sattr = Ast_c.s_of_attr defbis.f_attr in + pr2 (spf "%-30s: %s" defbis.f_name sattr); + ); + Visitor_c.kdecl = (fun (k, bigf) decl -> + match decl with + | DeclList (xs, ii) -> + xs +> List.iter (fun (onedecl, iicomma) -> + + let sattr = Ast_c.s_of_attr onedecl.v_attr in + let idname = + match onedecl.v_namei with + | Some ((s,ini), _) -> s + | None -> "novar" + in + pr2 (spf "%-30s: %s" idname sattr); + ); + | _ -> () + + ); + } ast; + () + + +let cpp_options () = [ + Cpp_ast_c.I "/home/yyzhou/pad/linux/include"; +] ++ + Cpp_ast_c.cpp_option_of_cmdline + (!Flag_parsing_c.cpp_i_opts,!Flag_parsing_c.cpp_d_opts) + +let test_cpp file = + let (ast2, _stat) = Parse_c.parse_c_and_cpp file in + let dirname = Filename.dirname file in + let ast = Parse_c.program_of_program2 ast2 in + let _ast' = Cpp_ast_c.cpp_expand_include (cpp_options()) dirname ast in + + () + + + + (* ---------------------------------------------------------------------- *) let test_xxx a = () @@ -257,6 +328,8 @@ let actions () = [ Common.mk_action_1_arg test_cfg; "-control_flow", " ", Common.mk_action_1_arg test_cfg; + "-test_cfg_ifdef", " ", + Common.mk_action_1_arg test_cfg_ifdef; "-parse_unparse", " ", Common.mk_action_1_arg test_parse_unparse; "-type_c", " ", @@ -267,6 +340,13 @@ let actions () = [ "-compare_c_hardcoded", " ", Common.mk_action_0_arg test_compare_c_hardcoded; + "-test_attributes", " ", + Common.mk_action_1_arg test_attributes; + "-test_cpp", " ", + Common.mk_action_1_arg test_cpp; + + + "-xxx", " <>", Common.mk_action_n_arg test_xxx; ] diff --git a/parsing_c/token_helpers.ml b/parsing_c/token_helpers.ml index 4fdf39c..5d70ad8 100644 --- a/parsing_c/token_helpers.ml +++ b/parsing_c/token_helpers.ml @@ -6,6 +6,12 @@ open Parser_c (* Is_xxx, categories *) (*****************************************************************************) +(* todo? could define a type + * token_class = Comment | Ident | Operator | ... + * but sometimes tokens belon to multiple classes. Could maybe return then + * a set of classes + *) + let is_space = function | TCommentSpace _ -> true | TCommentNewline _ -> true @@ -148,6 +154,28 @@ let is_stuff_taking_parenthized = function -> true | _ -> false + +let is_ident_like = function + | TIdent _ + | TypedefIdent _ + | TIdentDefine _ + | TDefParamVariadic _ + + | TUnknown _ + + | TMacroAttr _ + | TMacroAttrStorage _ + | TMacroStmt _ + | TMacroString _ + | TMacroDecl _ + | TMacroStructDecl _ + | TMacroDeclConst _ + | TMacroIterator _ + -> true + + | _ -> false + + (*****************************************************************************) (* Visitors *) (*****************************************************************************) @@ -458,3 +486,9 @@ let is_fake x = match pinfo_of_tok x with Ast_c.FakeTok _ -> true | _ -> false let is_abstract x = match pinfo_of_tok x with Ast_c.AbstractLineTok _ -> true | _ -> false + +(*****************************************************************************) +(* Helpers *) +(*****************************************************************************) +let is_same_line line tok = + line_of_tok tok = line diff --git a/parsing_c/token_helpers.mli b/parsing_c/token_helpers.mli index 0d7cfd8..b836ee3 100644 --- a/parsing_c/token_helpers.mli +++ b/parsing_c/token_helpers.mli @@ -21,6 +21,7 @@ val is_cpar : Parser_c.token -> bool val is_obrace : Parser_c.token -> bool val is_cbrace : Parser_c.token -> bool +val is_ident_like: Parser_c.token -> bool val info_of_tok : Parser_c.token -> Ast_c.info @@ -40,3 +41,5 @@ val is_origin : Parser_c.token -> bool val is_expanded : Parser_c.token -> bool val is_fake : Parser_c.token -> bool val is_abstract : Parser_c.token -> bool + +val is_same_line: int -> Parser_c.token -> bool diff --git a/parsing_c/type_annoter_c.ml b/parsing_c/type_annoter_c.ml index 21547ff..56215b0 100644 --- a/parsing_c/type_annoter_c.ml +++ b/parsing_c/type_annoter_c.ml @@ -9,6 +9,7 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * file license.txt for more details. *) + open Common open Ast_c @@ -16,31 +17,71 @@ open Ast_c module Lib = Lib_parsing_c (*****************************************************************************) -(* can either: - * - * - do a kind of inferer - * * can first do a simple inferer, that just pass context - * * then a real inferer, managing partial info. +(* Prelude *) +(*****************************************************************************) +(* History: + * - Done a first type checker in 2002, cf typing-semantic/, but + * was assuming that have all type info, and so was assuming had called + * cpp and everything was right. + * - Wrote this file, in 2006?, as we added pattern matching on type + * in coccinelle. Partial type annotater. + * - Julia extended it in 2008? to have localvar/notlocalvar and + * test/notest information, again used by coccinelle. + * - I extended it Fall 2008 to have more type information for the + * global analysis. I also added some optimisations to process + * included code faster. + * + * + * Design choices. Can either do: + * - a kind of inferer + * - can first do a simple inferer, that just pass context + * - then a real inferer, managing partial info. * type context = fullType option * * - extract the information from the .h files - * (so no inference at all needed) + * (so no inference at all needed) + * + * Difference with julia's code in parsing_cocci/type_infer.ml: + * - She handles just the variable namespace. She does not type + * field access or enum or macros. This is because cocci programs are + * usually simple and have no structure definition or macro definitions + * that we need to type anyway. + * - She does more propagation. + * - She does not have to handle the typedef isomorphism which force me + * to use those typedef_fix and type_unfold_one_step + * - She does not handle I think the function pointer C isomorphism. + * + * - She has a cleaner type_cocci without any info. In my case + * I need to do those ugly al_type, or generate fake infos. + * - She has more compact code. Perhaps because she does not have to + * handle the extra exp_info that she added on me :) So I need those + * do_with_type, make_info_xxx, etc. + * + * Note: if need to debug this annotater, use -show_trace_profile, it can + * help. You can also set the typedef_debug flag below. + * + * * * todo: expression contain types, and statements, which in turn can contain * expression, so need recurse. Need define an annote_statement and * annotate_type. - + * * todo: how deal with typedef isomorphisms ? How store them in Ast_c ? * store all posible variations in ast_c ? a list of type instead of just * the type ? * * todo: define a new type ? like type_cocci ? where have a bool ? * - * How handle scope ? When search for type of field, we return + * semi: How handle scope ? When search for type of field, we return * a type, but this type makes sense only in a certain scope. * We could add a tag to each typedef, structUnionName to differentiate * them and also associate in ast_c to the type the scope * of this type, the env that were used to define this type. + * + * todo: handle better the search in previous env, the env'. Cf the + * termination problem in typedef_fix when I was searching in the same + * env. + * *) (*****************************************************************************) @@ -54,13 +95,22 @@ let pr2 s = (* Environment *) (*****************************************************************************) -(* the different namespaces from stdC manual: +(* The different namespaces from stdC manual: * * You introduce two new name spaces with every block that you write. - * One name space includes all functions, objects, type definitions, - * and enumeration constants that you declare or define within the - * block. The other name space includes all enumeration, structure, and - * union tags that you define within the block. + * + * One name space includes all + * - functions, + * - objects, + * - type definitions, + * - and enumeration constants + * that you declare or define within the block. + * + * The other name space includes all + * - enumeration, + * - structure, + * - and union + * *tags* that you define within the block. * * You introduce a new member name space with every structure or union * whose content you define. You identify a member name space by the @@ -84,35 +134,94 @@ let pr2 s = *) -(* the wrap for StructUnionNameDef contain the whole ii, the i for - * the string, the structUnion and the structType +(* This type contains all "ident" like notion of C. Each time in Ast_c + * you have a string type (as in expression, function name, fields) + * then you need to manage the scope of this ident. + * + * The wrap for StructUnionNameDef contain the whole ii, the i for + * the string, the structUnion and the structType. + * + * Put Macro here ? after all the scoping rules for cpp macros is different + * and so does not vanish after the closing '}'. + * + * todo: EnumDef *) type namedef = | VarOrFunc of string * Ast_c.exp_type - | TypeDef of string * fullType + | EnumConstant of string * string option + + | TypeDef of string * fullType + (* the structType contains nested "idents" with struct scope *) | StructUnionNameDef of string * (structUnion * structType) wrap - (* todo: EnumConstant *) - (* todo: EnumDef *) -(* because have nested scope, have nested list, hence the list list *) + (* cppext: *) + | Macro of string * define_body + + +(* Because have nested scope, have nested list, hence the list list. + * + * opti? use a hash to accelerate ? hmm but may have some problems + * with hash to handle recursive lookup. For instance for the typedef + * example where have mutually recursive definition of the type, + * we must take care to not loop by starting the second search + * from the previous environment. With the list scheme in + * lookup_env below it's quite easy to do. With hash it may be + * more complicated. +*) type environment = namedef list list -let initial_env = [ - [VarOrFunc("NULL",(Lib.al_type (Parse_c.type_of_string "void *"), - Ast_c.NotLocalVar))] + +(* ------------------------------------------------------------ *) +(* can be modified by the init_env function below, by + * the file environment_unix.h + *) +let initial_env = ref [ + [VarOrFunc("NULL", + (Lib.al_type (Parse_c.type_of_string "void *"), + Ast_c.NotLocalVar)); + + (* + VarOrFunc("malloc", + (Lib.al_type(Parse_c.type_of_string "void* (*)(int size)"), + Ast_c.NotLocalVar)); + VarOrFunc("free", + (Lib.al_type(Parse_c.type_of_string "void (*)(void *ptr)"), + Ast_c.NotLocalVar)); + *) + ] ] -let rec lookup_env f env = +let typedef_debug = ref false + + +(* ------------------------------------------------------------ *) +(* generic, lookup and also return remaining env for further lookup *) +let rec lookup_env2 f env = match env with | [] -> raise Not_found - | []::zs -> lookup_env f zs + | []::zs -> lookup_env2 f zs | (x::xs)::zs -> - match f x with - | None -> lookup_env f (xs::zs) + (match f x with + | None -> lookup_env2 f (xs::zs) | Some y -> y, xs::zs + ) +let lookup_env a b = + Common.profile_code "TAC.lookup_env" (fun () -> lookup_env2 a b) + + + +let member_env lookupf env = + try + let _ = lookupf env in + true + with Not_found -> false + + + + +(* ------------------------------------------------------------ *) - let lookup_var s env = let f = function @@ -122,6 +231,7 @@ let lookup_var s env = lookup_env f env let lookup_typedef s env = + if !typedef_debug then pr2 ("looking for: " ^ s); let f = function | TypeDef (s2, typ) -> if s2 = s then Some typ else None | _ -> None @@ -135,11 +245,25 @@ let lookup_structunion (_su, s) env = in lookup_env f env -let member_env lookupf env = - try - let _ = lookupf env in - true - with Not_found -> false +let lookup_macro s env = + let f = function + | Macro (s2, typ) -> if s2 = s then Some typ else None + | _ -> None + in + lookup_env f env + +let lookup_enum s env = + let f = function + | EnumConstant (s2, typ) -> if s2 = s then Some typ else None + | _ -> None + in + lookup_env f env + + +let lookup_typedef a b = + Common.profile_code "TAC.lookup_typedef" (fun () -> lookup_typedef a b) + + (*****************************************************************************) (* "type-lookup" *) @@ -201,17 +325,20 @@ let rec find_final_type ty env = +(* ------------------------------------------------------------ *) let rec type_unfold_one_step ty env = match Ast_c.unwrap_typeC ty with - | BaseType x -> ty - | Pointer t -> ty - | Array (e, t) -> ty + | BaseType x -> ty + | Pointer t -> ty + | Array (e, t) -> ty + | StructUnion (sopt, su, fields) -> ty - | FunctionType t -> ty + | FunctionType t -> ty | Enum (s, enumt) -> ty - | EnumName s -> ty + + | EnumName s -> ty (* todo: look in env when will have EnumDef *) | StructUnionName (su, s) -> (try @@ -227,9 +354,10 @@ let rec type_unfold_one_step ty env = | TypeName (s,_typ) -> (try + if !typedef_debug then pr2 "type_unfold_one_step: lookup_typedef"; let (t', env') = lookup_typedef s env in type_unfold_one_step t' env' - with Not_found -> + with Not_found -> ty ) @@ -241,52 +369,28 @@ let rec type_unfold_one_step ty env = -let (type_field: - string -> (Ast_c.structUnion * Ast_c.structType) -> Ast_c.fullType) = - fun fld (su, fields) -> - fields +> Common.find_some (fun x -> - match Ast_c.unwrap x with - | DeclarationField (FieldDeclList (onefield_multivars, iiptvirg)) -> - Common.optionise (fun () -> - onefield_multivars +> Common.find_some (fun fieldkind -> - - match Ast_c.unwrap (Ast_c.unwrap fieldkind) with - | Simple (Some s, t) | BitField (Some s, t, _) -> - if s = fld then Some t else None - | _ -> None - ) - ) - | EmptyField -> None - | MacroStructDeclTodo -> pr2 "DeclTodo"; None - | CppDirectiveStruct _ - | IfdefStruct _ -> pr2 "StructCpp"; None - ) - -let structdef_to_struct_name ty = - match ty with - | qu, (StructUnion (su, sopt, fields), iis) -> - (match sopt,iis with - | Some s , [i1;i2;i3;i4] -> - qu, (StructUnionName (su, s), [i1;i2]) - | None, _ -> - ty - - | x -> raise Impossible - ) - | _ -> raise Impossible +(* normalizer. can be seen as the opposite of the previous function as + * we "fold" at least for the structUnion. + *) let rec typedef_fix ty env = - match Ast_c.unwrap_typeC ty with - | BaseType x -> ty - | Pointer t -> Pointer (typedef_fix t env) +> Ast_c.rewrap_typeC ty - | Array (e, t) -> Array (e, typedef_fix t env) +> Ast_c.rewrap_typeC ty - | StructUnion (su, sopt, fields) -> structdef_to_struct_name ty + | BaseType x -> + ty + | Pointer t -> + Pointer (typedef_fix t env) +> Ast_c.rewrap_typeC ty + | Array (e, t) -> + Array (e, typedef_fix t env) +> Ast_c.rewrap_typeC ty + | StructUnion (su, sopt, fields) -> + (* normalize, fold. + * todo? but what if correspond to a nested struct def ? + *) + Type_c.structdef_to_struct_name ty | FunctionType ft -> (FunctionType ft) (* todo ? *) +> Ast_c.rewrap_typeC ty | Enum (s, enumt) -> @@ -296,28 +400,88 @@ let rec typedef_fix ty env = (* we prefer StructUnionName to StructUnion when it comes to typed metavar *) | StructUnionName (su, s) -> ty - + + (* keep the typename but complete with more information *) | TypeName (s, _typ) -> (try + if !typedef_debug then pr2 "typedef_fix: lookup_typedef"; let (t', env') = lookup_typedef s env in - TypeName (s, Some (typedef_fix t' env)) +> Ast_c.rewrap_typeC ty - with Not_found -> + + (* bugfix: termination bug if use env instead of env' below, because + * can have some wierd mutually recursive typedef which + * each new type alias search for its mutual def. + *) + TypeName (s, Some (typedef_fix t' env')) +> Ast_c.rewrap_typeC ty + with Not_found -> ty ) - - | ParenType t -> typedef_fix t env + (* remove paren for better matching with typed metavar. kind of iso again *) + | ParenType t -> + typedef_fix t env | TypeOfExpr e -> pr2_once ("Type_annoter: not handling typeof"); ty - | TypeOfType t -> typedef_fix t env + | TypeOfType t -> + typedef_fix t env + + +(*****************************************************************************) +(* Helpers, part 1 *) +(*****************************************************************************) + +let type_of_s2 s = + (Lib.al_type (Parse_c.type_of_string s)) +let type_of_s a = + Common.profile_code "Type_c.type_of_s" (fun () -> type_of_s2 a) + + +(* pad: pb on: + * /home/pad/software-os-src2/freebsd/contrib/ipfilter/netinet/ip_fil_freebsd.c + * because in the code there is: + * static iss_seq_off = 0; + * which in the parser was generating a default int without a parse_info. + * I now add a fake parse_info for such default int so no more failwith + * normally. + *) +let offset (_,(ty,iis)) = + match iis with + ii::_ -> ii.Ast_c.pinfo + | _ -> failwith "type has no text; need to think again" + + + +let rec is_simple_expr expr = + match Ast_c.unwrap_expr expr with + (* todo? handle more special cases ? *) + + | Ident _ -> + true + | Constant (_) -> + true + | Unary (op, e) -> + true + | Binary (e1, op, e2) -> + true + | Cast (t, e) -> + true + | ParenExpr (e) -> is_simple_expr e + + | _ -> false + +(*****************************************************************************) +(* Typing rules *) +(*****************************************************************************) +(* now in type_c.ml *) + + (*****************************************************************************) (* (Semi) Globals, Julia's style *) (*****************************************************************************) (* opti: cache ? use hash ? *) -let _scoped_env = ref initial_env +let _scoped_env = ref !initial_env (* memoise unnanoted var, to avoid too much warning messages *) let _notyped_var = ref (Hashtbl.create 100) @@ -337,236 +501,584 @@ let add_in_scope namedef = let (current, older) = Common.uncons !_scoped_env in _scoped_env := (namedef::current)::older + +(* ------------------------------------------------------------ *) + (* sort of hackish... *) let islocal info = - if List.length (!_scoped_env) = List.length initial_env + if List.length (!_scoped_env) = List.length !initial_env then Ast_c.NotLocalVar else Ast_c.LocalVar info +(* ------------------------------------------------------------ *) (* the warning argument is here to allow some binding to overwrite an - * existing one. With function, we first have the protype and then the def - * and the def binding the same string is not an error. + * existing one. With function, we first have the prototype and then the def, + * and the def binding with the same string is not an error. + * * todo?: but if we define two times the same function, then we will not - * detect it :( would require to make a diff between adding a binding + * detect it :( it would require to make a diff between adding a binding * from a prototype and from a definition. + * + * opti: disabling the check_annotater flag have some important + * performance benefit. + * *) -let add_binding namedef warning = +let add_binding2 namedef warning = let (current_scope, _older_scope) = Common.uncons !_scoped_env in - (match namedef with - | VarOrFunc (s, typ) -> - if Hashtbl.mem !_notyped_var s - then pr2 ("warning: found typing information for a variable that was" ^ - "previously unknown:" ^ s); - | _ -> () - ); - - let (memberf, s) = + if !Flag_parsing_c.check_annotater then begin (match namedef with - | VarOrFunc (s, typ) -> member_env (lookup_var s), s - | TypeDef (s, typ) -> member_env (lookup_typedef s), s - | StructUnionNameDef (s, (su, typ)) -> - member_env (lookup_structunion (su, s)), s - ) in - - if memberf [current_scope] && warning - then pr2 ("Type_annoter: warning, " ^ s ^ - " is already in current binding" ^ "\n" ^ - " so there is a wierd shadowing"); + | VarOrFunc (s, typ) -> + if Hashtbl.mem !_notyped_var s + then pr2 ("warning: found typing information for a variable that was" ^ + "previously unknown:" ^ s); + | _ -> () + ); + + let (memberf, s) = + (match namedef with + | VarOrFunc (s, typ) -> + member_env (lookup_var s), s + | TypeDef (s, typ) -> + member_env (lookup_typedef s), s + | StructUnionNameDef (s, (su, typ)) -> + member_env (lookup_structunion (su, s)), s + | Macro (s, body) -> + member_env (lookup_macro s), s + | EnumConstant (s, body) -> + member_env (lookup_enum s), s + ) in + + if memberf [current_scope] && warning + then pr2 ("Type_annoter: warning, " ^ s ^ + " is already in current binding" ^ "\n" ^ + " so there is a wierd shadowing"); + end; add_in_scope namedef + +let add_binding namedef warning = + Common.profile_code "TAC.add_binding" (fun () -> add_binding2 namedef warning) + (*****************************************************************************) -(* Helpers *) +(* Helpers, part 2 *) (*****************************************************************************) -let make_info t = (Some t,Ast_c.NotTest) +let lookup_opt_env lookupf s = + Common.optionise (fun () -> + lookupf s !_scoped_env + ) + +let unwrap_unfold_env2 typ = + Ast_c.unwrap_typeC + (type_unfold_one_step typ !_scoped_env) +let unwrap_unfold_env typ = + Common.profile_code "TAC.unwrap_unfold_env" (fun () -> unwrap_unfold_env2 typ) -let type_of_s s = - (Lib.al_type (Parse_c.type_of_string s), Ast_c.NotLocalVar) +let typedef_fix a b = + Common.profile_code "TAC.typedef_fix" (fun () -> typedef_fix a b) -let noTypeHere = (None,Ast_c.NotTest) +let make_info_def_fix x = + Type_c.make_info_def (typedef_fix x !_scoped_env) -let do_with_type f (t,_test) = - match t with - | None -> noTypeHere - | Some (t,_local) -> f t +let make_info_fix (typ, local) = + Type_c.make_info ((typedef_fix typ !_scoped_env),local) + + +let make_info_def = Type_c.make_info_def - (*****************************************************************************) -(* Entry point *) +(* Main typer code, put later in a visitor *) (*****************************************************************************) -(* catch all the decl to grow the environment *) - -let rec (annotate_program2 : - environment -> toplevel list -> (toplevel * environment Common.pair) list - ) = fun env prog -> - (* globals (re)initialialisation *) - _scoped_env := env; - _notyped_var := (Hashtbl.create 100); +let annotater_expr_visitor_subpart = (fun (k,bigf) expr -> + let ty = + match Ast_c.unwrap_expr expr with + + (* -------------------------------------------------- *) + (* todo: should analyse the 's' for int to know if unsigned or not *) + | Constant (String (s,kind)) -> make_info_def (type_of_s "char *") + | Constant MultiString -> make_info_def (type_of_s "char *") + | Constant (Char (s,kind)) -> make_info_def (type_of_s "char") + | Constant (Int (s)) -> make_info_def (type_of_s "int") + | Constant (Float (s,kind)) -> + let fake = Ast_c.fakeInfo (Common.fake_parse_info) in + let fake = Ast_c.rewrap_str "float" fake in + let iinull = [fake] in + make_info_def + (Ast_c.nQ, (BaseType (FloatType kind), iinull)) + + + (* -------------------------------------------------- *) + (* note: could factorize this code with the code for Ident + * and the other code for Funcall below. But as the Ident can be + * a macro-func, I prefer to handle it separately. So + * this rule can handle the macro-func, the Ident-rule can handle + * the macro-var, and the other FunCall-rule the regular + * function calls through fields. + * Also as I don't want a warning on the Ident that are a FunCall, + * easier to have a rule separate from the Ident rule. + *) + | FunCall (((Ident s, typ), ii) as e1, args) -> + + (* recurse *) + args +> List.iter (fun (e,ii) -> + (* could typecheck if arguments agree with prototype *) + Visitor_c.vk_argument bigf e + ); + + (match lookup_opt_env lookup_var s with + | Some ((typ,local),_nextenv) -> + + (* set type for ident *) + let tyinfo = make_info_fix (typ, local) in + Ast_c.set_type_expr e1 tyinfo; + + (match unwrap_unfold_env typ with + | FunctionType (ret, params) -> make_info_def ret + + (* can be function pointer, C have an iso for that, + * same pfn() syntax than regular function call. + *) + | Pointer (typ2) -> + (match unwrap_unfold_env typ2 with + | FunctionType (ret, params) -> make_info_def ret + | _ -> Type_c.noTypeHere + ) + | _ -> Type_c.noTypeHere + ) + | None -> + + (match lookup_opt_env lookup_macro s with + | Some ((defkind, defval), _nextenv) -> + (match defkind, defval with + | DefineFunc _, DefineExpr e -> + let rettype = Ast_c.get_onlytype_expr e in + + (* todo: could also set type for ident ? + have return type and at least type of concrete + parameters so can generate a fake FunctionType + *) + let macrotype_opt = + Type_c.fake_function_type rettype args + in + + macrotype_opt +> Common.do_option (fun t -> + pr2 ("Type_annotater: generate fake function type" ^ + "for macro: " ^ s); + let tyinfo = make_info_def_fix t in + Ast_c.set_type_expr e1 tyinfo; + ); + + Ast_c.get_type_expr e + | DefineVar, _ -> + pr2 ("Type_annoter: not a macro-func: " ^ s); + Type_c.noTypeHere + | DefineFunc _, _ -> + (* normally the FunCall case should have catch it *) + pr2 ("Type_annoter: not a macro-func-expr: " ^ s); + Type_c.noTypeHere + ) + | None -> + pr2 ("type_annotater: no type for function ident: " ^ s); + Type_c.noTypeHere + ) + ) - let bigf = { Visitor_c.default_visitor_c with - Visitor_c.kexpr = (fun (k,bigf) expr -> - k expr; (* recurse to set the types-ref of sub expressions *) - let ty = - match Ast_c.unwrap_expr expr with - (* todo: should analyse the 's' for int to know if unsigned or not *) - | Constant (String (s,kind)) -> make_info (type_of_s "char *") - | Constant (Char (s,kind)) -> make_info (type_of_s "char") - | Constant (Int (s)) -> make_info (type_of_s "int") - | Constant (Float (s,kind)) -> - let iinull = [] in - make_info - ((Ast_c.nQ, (BaseType (FloatType kind), iinull)), - Ast_c.NotLocalVar) - - (* don't want a warning on the Ident that are a FunCall *) - | FunCall (((Ident f, typ), ii), args) -> - args +> List.iter (fun (e,ii) -> - Visitor_c.vk_argument bigf e - ); - noTypeHere - - | Ident (s) -> - (match (Common.optionise (fun () -> lookup_var s !_scoped_env)) with - | Some ((typ,local),_nextenv) -> - make_info ((typedef_fix typ !_scoped_env),local) - | None -> - if not (s =~ "[A-Z_]+") (* if macro then no warning *) - then - if not (Hashtbl.mem !_notyped_var s) - then begin - pr2 ("Type_annoter: not finding type for " ^ s); - Hashtbl.add !_notyped_var s true; - end; - noTypeHere - ) - | Unary (e, UnMinus) | Unary (e, UnPlus) -> make_info (type_of_s "int") - | Unary (e, DeRef) - | ArrayAccess (e, _) -> - (Ast_c.get_type_expr e) +> do_with_type (fun t -> - (* todo: maybe not good env !! *) - match Ast_c.unwrap_typeC (type_unfold_one_step t !_scoped_env) with - | Pointer x - | Array (_, x) -> - make_info ((typedef_fix x !_scoped_env),Ast_c.NotLocalVar) - | _ -> noTypeHere + | FunCall (e, args) -> + k expr; + + (Ast_c.get_type_expr e) +> Type_c.do_with_type (fun typ -> + (* copy paste of above *) + (match unwrap_unfold_env typ with + | FunctionType (ret, params) -> make_info_def ret + | Pointer (typ) -> + (match unwrap_unfold_env typ with + | FunctionType (ret, params) -> make_info_def ret + | _ -> Type_c.noTypeHere + ) + | _ -> Type_c.noTypeHere ) + ) + + + (* -------------------------------------------------- *) + | Ident (s) -> + (match lookup_opt_env lookup_var s with + | Some ((typ,local),_nextenv) -> + make_info_fix (typ,local) + | None -> + (match lookup_opt_env lookup_macro s with + | Some ((defkind, defval), _nextenv) -> + (match defkind, defval with + | DefineVar, DefineExpr e -> + Ast_c.get_type_expr e + | DefineVar, _ -> + pr2 ("Type_annoter: not a expression: " ^ s); + Type_c.noTypeHere + | DefineFunc _, _ -> + (* normally the FunCall case should have catch it *) + pr2 ("Type_annoter: not a macro-var: " ^ s); + Type_c.noTypeHere + ) + | None -> + (match lookup_opt_env lookup_enum s with + | Some (_, _nextenv) -> + make_info_def (type_of_s "int") + | None -> + if not (s =~ "[A-Z_]+") (* if macro then no warning *) + then + if !Flag_parsing_c.check_annotater then + if not (Hashtbl.mem !_notyped_var s) + then begin + pr2 ("Type_annoter: not finding type for: " ^ s); + Hashtbl.add !_notyped_var s true; + end + else () + else + pr2 ("Type_annoter: not finding type for: " ^ s) + ; + Type_c.noTypeHere + ) + ) + ) + + (* -------------------------------------------------- *) + (* C isomorphism on type on array and pointers *) + | Unary (e, DeRef) + | ArrayAccess (e, _) -> + k expr; (* recurse to set the types-ref of sub expressions *) + + (Ast_c.get_type_expr e) +> Type_c.do_with_type (fun t -> + (* todo: maybe not good env !! *) + match unwrap_unfold_env t with + | Pointer x + | Array (_, x) -> + make_info_def_fix x + | _ -> Type_c.noTypeHere + + ) + + | Unary (e, GetRef) -> + k expr; (* recurse to set the types-ref of sub expressions *) + + (Ast_c.get_type_expr e) +> Type_c.do_with_type (fun t -> + (* must generate an element so that '=' can be used + * to compare type ? + *) + let fake = Ast_c.fakeInfo Common.fake_parse_info in + let fake = Ast_c.rewrap_str "*" fake in + + let ft = (Ast_c.nQ, (Pointer t, [fake])) in + make_info_def_fix ft + ) + + + (* -------------------------------------------------- *) + (* fields *) + | RecordAccess (e, fld) + | RecordPtAccess (e, fld) as x -> - | RecordAccess (e, fld) -> - (Ast_c.get_type_expr e) +> do_with_type (fun t -> - match Ast_c.unwrap_typeC (type_unfold_one_step t !_scoped_env) with - | StructUnion (su, sopt, fields) -> - (try - (* todo: which env ? *) - make_info - ((typedef_fix (type_field fld (su, fields)) !_scoped_env), - Ast_c.NotLocalVar) - with Not_found -> - pr2 - ("TYPE-ERROR: field '" ^ fld ^ "' does not belong in" ^ - " struct '"^(match sopt with Some s -> s |_ -> "")^ - "'"); - noTypeHere + k expr; (* recurse to set the types-ref of sub expressions *) + + (Ast_c.get_type_expr e) +> Type_c.do_with_type (fun t -> + + let topt = + match x with + | RecordAccess _ -> Some t + | RecordPtAccess _ -> + (match unwrap_unfold_env t with + | Pointer (t) -> Some t + | _ -> None ) - | _ -> noTypeHere + | _ -> raise Impossible + + in + (match topt with + | None -> Type_c.noTypeHere + | Some t -> + match unwrap_unfold_env t with + | StructUnion (su, sopt, fields) -> + (try + (* todo: which env ? *) + make_info_def_fix + (Type_c.type_field fld (su, fields)) + with + | Not_found -> + pr2 (spf + "TYPE-ERROR: field '%s' does not belong in struct %s" + fld (match sopt with Some s -> s |_ -> "")); + Type_c.noTypeHere + | MultiFound -> + pr2 "TAC:MultiFound"; + Type_c.noTypeHere + ) + | _ -> Type_c.noTypeHere ) + ) + + + + (* -------------------------------------------------- *) + | Cast (t, e) -> + k expr; + (* todo: if infer, can "push" info ? add_types_expr [t] e ? *) + make_info_def_fix (Lib.al_type t) + + (* todo? lub, hmm maybe not, cos type must be e1 *) + | Assignment (e1, op, e2) -> + k expr; + Ast_c.get_type_expr e1 + | Sequence (e1, e2) -> + k expr; + Ast_c.get_type_expr e2 + + (* todo: lub *) + | Binary (e1, op, e2) -> + k expr; + Type_c.lub (Type_c.get_opt_type e1) (Type_c.get_opt_type e2) + + | CondExpr (cond, e1opt, e2) -> + k expr; + Ast_c.get_type_expr e2 - | RecordPtAccess (e, fld) -> - (Ast_c.get_type_expr e) +> do_with_type (fun t -> - match Ast_c.unwrap_typeC (type_unfold_one_step t !_scoped_env) with - | Pointer (t) -> - (match Ast_c.unwrap_typeC (type_unfold_one_step t !_scoped_env) - with - | StructUnion (su, sopt, fields) -> - (try - (* todo: which env ? *) - make_info - ((typedef_fix (type_field fld (su, fields)) !_scoped_env), - Ast_c.NotLocalVar) - with Not_found -> - pr2 - ("TYPE-ERROR: field '" ^ fld ^ "' does not belong in" ^ - " struct '"^(match sopt with Some s -> s |_ -> "")^ - "'"); - noTypeHere - ) - | _ -> noTypeHere + | ParenExpr e -> + k expr; + Ast_c.get_type_expr e + + | Infix (e, op) | Postfix (e, op) -> + k expr; + Ast_c.get_type_expr e + + (* pad: julia wrote this ? *) + | Unary (e, UnPlus) -> + k expr; (* recurse to set the types-ref of sub expressions *) + make_info_def (type_of_s "int") + (* todo? can convert from unsigned to signed if UnMinus ? *) + | Unary (e, UnMinus) -> + k expr; (* recurse to set the types-ref of sub expressions *) + make_info_def (type_of_s "int") + + | SizeOfType _|SizeOfExpr _ -> + k expr; (* recurse to set the types-ref of sub expressions *) + make_info_def (type_of_s "int") + + | Constructor (ft, ini) -> + k expr; (* recurse to set the types-ref of sub expressions *) + make_info_def (Lib.al_type ft) + + | Unary (e, Not) -> + k expr; (* recurse to set the types-ref of sub expressions *) + Ast_c.get_type_expr e + | Unary (e, Tilde) -> + k expr; (* recurse to set the types-ref of sub expressions *) + Ast_c.get_type_expr e + + (* -------------------------------------------------- *) + (* todo *) + | Unary (_, GetRefLabel) -> + k expr; (* recurse to set the types-ref of sub expressions *) + pr2_once "Type annotater:not handling GetRefLabel"; + Type_c.noTypeHere + (* todo *) + | StatementExpr _ -> + k expr; (* recurse to set the types-ref of sub expressions *) + pr2_once "Type annotater:not handling GetRefLabel"; + Type_c.noTypeHere + (* + | _ -> k expr; Type_c.noTypeHere + *) + + in + Ast_c.set_type_expr expr ty + +) + + +(*****************************************************************************) +(* Visitor *) +(*****************************************************************************) + +(* Processing includes that were added after a cpp_ast_c makes the + * type annotater quite slow, especially when the depth of cpp_ast_c is + * big. But for such includes the only thing we really want is to modify + * the environment to have enough type information. We don't need + * to type the expressions inside those includes (they will be typed + * when we process the include file directly). Here the goal is + * to not recurse. + * + * Note that as usually header files contain mostly structure + * definitions and defines, that means we still have to do lots of work. + * We only win on function definition bodies, but usually header files + * have just prototypes, or inline function definitions which anyway have + * usually a small body. But still, we win. It also makes clearer + * that when processing include as we just need the environment, the caller + * of this module can do further optimisations such as memorising the + * state of the environment after each header files. + * + * + * For sparse its makes the annotating speed goes from 9s to 4s + * For Linux the speedup is even better, from ??? to ???. + * + * Because There would be some copy paste with annotate_program, it is + * better to factorize code hence the just_add_in_env parameter below. + * + * todo? alternative optimisation for the include problem: + * - processing all headers files one time and construct big env + * - use hashtbl for env (but apparently not biggest problem) + *) + +let rec visit_toplevel ~just_add_in_env ~depth elem = + let need_annotate_body = not just_add_in_env in + + let bigf = { Visitor_c.default_visitor_c with + + (* ------------------------------------------------------------ *) + Visitor_c.kcppdirective = (fun (k, bigf) directive -> + match directive with + (* do error messages for type annotater only for the real body of the + * file, not inside include. + *) + | Include {i_content = opt} -> + opt +> Common.do_option (fun (filename, program) -> + Common.save_excursion Flag_parsing_c.verbose_type (fun () -> + Flag_parsing_c.verbose_type := false; + + (* old: Visitor_c.vk_program bigf program; + * opti: set the just_add_in_env + *) + program +> List.iter (fun elem -> + visit_toplevel ~just_add_in_env:true ~depth:(depth+1) elem ) - | _ -> noTypeHere + ) ) - | Cast (t, e) -> - (* todo: add_types_expr [t] e ? *) - make_info - ((typedef_fix (Lib.al_type t) !_scoped_env),Ast_c.NotLocalVar) - - (* todo: check e2 ? *) - | Assignment (e1, op, e2) -> - Ast_c.get_type_expr e1 - | ParenExpr e -> - Ast_c.get_type_expr e - - | _ -> noTypeHere - in - Ast_c.set_type_expr expr ty - + + | Define ((s,ii), (defkind, defval)) -> + + + (* even if we are in a just_add_in_env phase, such as when + * we process include, as opposed to the body of functions, + * with macros we still to type the body of the macro as + * the macro has no type and so we infer its type from its + * body (and one day later maybe from its use). + *) + (match defval with + (* can try to optimize and recurse only when the define body + * is simple ? + *) + + | DefineExpr expr -> + if is_simple_expr expr + (* even if not need_annotate_body, still recurse*) + then k directive + else + if need_annotate_body + then k directive; + | _ -> + if need_annotate_body + then k directive; + ); + + add_binding (Macro (s, (defkind, defval) )) true; + + | Undef _ + | PragmaAndCo _ -> () ); + (* ------------------------------------------------------------ *) + (* main typer code *) + (* ------------------------------------------------------------ *) + Visitor_c.kexpr = annotater_expr_visitor_subpart; + + (* ------------------------------------------------------------ *) Visitor_c.kstatement = (fun (k, bigf) st -> match st with | Compound statxs, ii -> do_in_new_scope (fun () -> k st); | _ -> k st - ); + (* ------------------------------------------------------------ *) Visitor_c.kdecl = (fun (k, bigf) d -> (match d with | (DeclList (xs, ii)) -> xs +> List.iter (fun ({v_namei = var; v_type = t; v_storage = sto; v_local = local}, iicomma) -> - let local = - match local with - Ast_c.NotLocalDecl -> Ast_c.NotLocalVar - | Ast_c.LocalDecl -> Ast_c.LocalVar (offset t) in - (* to add possible definition in type found in Decl *) Visitor_c.vk_type bigf t; + + + let local = + match local with + | Ast_c.NotLocalDecl -> Ast_c.NotLocalVar + | Ast_c.LocalDecl -> Ast_c.LocalVar (offset t) + in - var +> do_option (fun ((s, ini), ii_s_ini) -> + var +> Common.do_option (fun ((s, ini), ii_s_ini) -> match sto with | StoTypedef, _inline -> add_binding (TypeDef (s,Lib.al_type t)) true; | _ -> add_binding (VarOrFunc (s, (Lib.al_type t, local))) true; - (* int x = sizeof(x) is legal so need process ini *) - ini +> Common.do_option (fun ini -> - Visitor_c.vk_ini bigf ini); + + + if need_annotate_body then begin + (* int x = sizeof(x) is legal so need process ini *) + ini +> Common.do_option (fun ini -> + Visitor_c.vk_ini bigf ini + ); + end ); ); - | _ -> k d + | MacroDecl _ -> + if need_annotate_body + then k d ); ); + (* ------------------------------------------------------------ *) Visitor_c.ktype = (fun (k, bigf) typ -> - let (q, t) = Lib.al_type typ in + (* bugfix: have a 'Lib.al_type typ' before, but because we can + * have enum with possible expression, we don't want to change + * the ref of abstract-lined types, but the real one, so + * don't al_type here + *) + let (_q, t) = typ in match t with | StructUnion (su, Some s, structType),ii -> - add_binding (StructUnionNameDef (s, ((su, structType),ii))) true; - k typ (* todo: restrict ? new scope so use do_in_scope ? *) + let structType' = Lib.al_fields structType in + let ii' = Lib.al_ii ii in + add_binding (StructUnionNameDef (s, ((su, structType'),ii'))) true; + + if need_annotate_body + then k typ (* todo: restrict ? new scope so use do_in_scope ? *) + + | Enum (sopt, enums), ii -> + + enums +> List.iter (fun (((s, eopt),ii_s_eq), iicomma) -> + + if need_annotate_body + then eopt +> Common.do_option (fun e -> + Visitor_c.vk_expr bigf e + ); + add_binding (EnumConstant (s, sopt)) true; + ); (* TODO: if have a TypeName, then maybe can fill the option * information. *) - | _ -> k typ + | _ -> + if need_annotate_body + then k typ ); + (* ------------------------------------------------------------ *) Visitor_c.ktoplevel = (fun (k, bigf) elem -> _notyped_var := Hashtbl.create 100; match elem with @@ -574,7 +1086,10 @@ let rec (annotate_program2 : let {f_name = funcs; f_type = ((returnt, (paramst, b)) as ftyp); f_storage = sto; - f_body = statxs},ii = def + f_body = statxs; + f_old_c_style = oldstyle; + },ii + = def in let (i1, i2) = match ii with @@ -582,37 +1097,94 @@ let rec (annotate_program2 : iifunc1, iifunc2 | _ -> raise Impossible in - let typ' = Lib.al_type (Ast_c.nQ, (FunctionType ftyp, [i1;i2])) in - - add_binding (VarOrFunc (funcs, (typ',islocal i1.Ast_c.pinfo))) false; - do_in_new_scope (fun () -> - paramst +> List.iter (fun (((b, s, t), _),_) -> - match s with - | Some s -> - let local = Ast_c.LocalVar (offset t) in - add_binding (VarOrFunc (s,(Lib.al_type t,local))) true - | None -> pr2 "no type, certainly because Void type ?" - ); - k elem + + (match oldstyle with + | None -> + let typ' = + Lib.al_type (Ast_c.nQ, (FunctionType ftyp, [i1;i2])) in + + add_binding (VarOrFunc (funcs, (typ',islocal i1.Ast_c.pinfo))) + false; + + if need_annotate_body then + do_in_new_scope (fun () -> + paramst +> List.iter (fun (((b, s, t), _),_) -> + match s with + | Some s -> + let local = Ast_c.LocalVar (offset t) in + add_binding (VarOrFunc (s,(Lib.al_type t,local))) true + | None -> + pr2 "no type, certainly because Void type ?" + ); + (* recurse *) + k elem + ); + | Some oldstyle -> + (* generate regular function type *) + + pr2 "TODO generate type for function"; + (* add bindings *) + if need_annotate_body then + do_in_new_scope (fun () -> + (* recurse. should naturally call the kdecl visitor and + * add binding + *) + k elem; + ); + ); - | _ -> k elem + | Declaration _ + + | CppTop _ + | IfdefTop _ + | MacroTop _ + | EmptyDef _ + | NotParsedCorrectly _ + | FinalDef _ + -> + k elem ); } in + if just_add_in_env + then + if depth > 1 + then Visitor_c.vk_toplevel bigf elem + else + Common.profile_code "TAC.annotate_only_included" (fun () -> + Visitor_c.vk_toplevel bigf elem + ) + else Visitor_c.vk_toplevel bigf elem + +(*****************************************************************************) +(* Entry point *) +(*****************************************************************************) +(* catch all the decl to grow the environment *) + + +let rec (annotate_program2 : + environment -> toplevel list -> (toplevel * environment Common.pair) list) = + fun env prog -> + + (* globals (re)initialialisation *) + _scoped_env := env; + _notyped_var := (Hashtbl.create 100); prog +> List.map (fun elem -> let beforeenv = !_scoped_env in - Visitor_c.vk_toplevel bigf elem; + visit_toplevel ~just_add_in_env:false ~depth:0 elem; let afterenv = !_scoped_env in (elem, (beforeenv, afterenv)) ) -and offset (_,(ty,iis)) = - match iis with - ii::_ -> ii.Ast_c.pinfo - | _ -> failwith "type has no text; need to think again" - - + + + +(*****************************************************************************) +(* Annotate test *) +(*****************************************************************************) + +(* julia: for coccinelle *) let annotate_test_expressions prog = let rec propagate_test e = let ((e_term,info),_) = e in @@ -629,8 +1201,10 @@ let annotate_test_expressions prog = Visitor_c.kexpr = (fun (k,bigf) expr -> (match unwrap expr with (CondExpr(e,_,_),_) -> propagate_test e - | _ -> ()); - k expr); + | _ -> () + ); + k expr + ); Visitor_c.kstatement = (fun (k, bigf) st -> match unwrap st with Selection(s) -> @@ -644,17 +1218,42 @@ let annotate_test_expressions prog = (match unwrap es with Some e -> propagate_test e | None -> ()) | _ -> ()); k st - | _ -> k st) } in + | _ -> k st + ) + } in (prog +> List.iter (fun elem -> Visitor_c.vk_toplevel bigf elem )) -let annotate_program a types_needed = - Common.profile_code "annotate_type" - (fun () prog -> - let res = - if true (*types_needed*) - then annotate_program2 a prog - else prog +> List.map (fun c -> c, (initial_env, initial_env)) in + + +(*****************************************************************************) +(* Annotate types *) +(*****************************************************************************) +let annotate_program env prog = + Common.profile_code "TAC.annotate_program" + (fun () -> + let res = annotate_program2 env prog in annotate_test_expressions prog; - res) + res + ) + +let annotate_type_and_localvar env prog = + Common.profile_code "TAC.annotate_type" + (fun () -> annotate_program2 env prog) + + +(*****************************************************************************) +(* changing default typing environment, do concatenation *) +let init_env filename = + pr2 ("init_env: " ^ filename); + let (ast2, _stat) = Parse_c.parse_c_and_cpp filename in + let ast = Parse_c.program_of_program2 ast2 in + + let res = annotate_type_and_localvar !initial_env ast in + match List.rev res with + | [] -> pr2 "empty environment" + | (_top,(env1,env2))::xs -> + initial_env := !initial_env ++ env2; + () + diff --git a/parsing_c/type_annoter_c.mli b/parsing_c/type_annoter_c.mli dissimilarity index 82% index 9a98877..02f401e 100644 --- a/parsing_c/type_annoter_c.mli +++ b/parsing_c/type_annoter_c.mli @@ -1,17 +1,37 @@ - -type namedef = - | VarOrFunc of string * Ast_c.exp_type - | TypeDef of string * Ast_c.fullType - | StructUnionNameDef of - string * (Ast_c.structUnion * Ast_c.structType) Ast_c.wrap - -type environment = namedef list list (* cos have nested scope, so nested list*) - -val initial_env : environment - -(* In fact do via side effects. Fill in the type information that was put - * to None during parsing - *) -val annotate_program : - environment -> bool (*true if types needed*) -> Ast_c.toplevel list -> - (Ast_c.toplevel * environment Common.pair) list +type namedef = + | VarOrFunc of string * Ast_c.exp_type + | EnumConstant of string * string option + + | TypeDef of string * Ast_c.fullType + | StructUnionNameDef of string * + (Ast_c.structUnion * Ast_c.structType) Ast_c.wrap + + | Macro of string * Ast_c.define_body + +(* have nested scope, so nested list*) +type environment = namedef list list + +(* can be set with init_env *) +val initial_env : environment ref +(* ex: config/envos/environment_unix.h *) +val init_env : Common.filename -> unit + + + +val annotate_type_and_localvar : + environment -> Ast_c.toplevel list -> + (Ast_c.toplevel * environment Common.pair) list + +(* julia: cocci *) +val annotate_test_expressions : + Ast_c.toplevel list -> unit + + + +(* Annotate via side effects. Fill in the type + * information that was put to None during parsing. + *) +val annotate_program : + environment -> Ast_c.toplevel list -> + (Ast_c.toplevel * environment Common.pair) list + diff --git a/parsing_c/type_c.ml b/parsing_c/type_c.ml new file mode 100644 index 0000000..cc53391 --- /dev/null +++ b/parsing_c/type_c.ml @@ -0,0 +1,309 @@ +(* Copyright (C) 2007, 2008 Yoann Padioleau + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License (GPL) + * version 2 as published by the Free Software Foundation. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * file license.txt for more details. + *) + +open Common + +open Ast_c + +(*****************************************************************************) +(* Types *) +(*****************************************************************************) + +(* todo? define a new clean fulltype ? as julia did with type_cocci.ml + * without the parsing info, with some normalization (for instance have + * only structUnionName and enumName, and remove the ParenType), some + * abstractions (don't care for instance about name in parameters of + * functionType, or size of array), and with new types such as Unknown + * or PartialFunctionType (when don't have type of return when infer + * the type of function call not based on type of function but on the + * type of its arguments). + * + * + * + *) + +type finalType = Ast_c.fullType + +(*****************************************************************************) +(* expression exp_info annotation vs finalType *) +(*****************************************************************************) + +(* builders, needed because julia added gradually more information in + * the expression reference annotation in ast_c. + *) + +let make_info x = + (Some x, Ast_c.NotTest) + +let make_exp_type t = + (t, Ast_c.NotLocalVar) + +let make_info_def t = + make_info (make_exp_type t) + + + +let noTypeHere = + (None, Ast_c.NotTest) + + + + + +let do_with_type f (t,_test) = + match t with + | None -> noTypeHere + | Some (t,_local) -> f t + +let get_opt_type e = + match Ast_c.get_type_expr e with + | Some (t,_), _test -> Some t + | None, _test -> None + + + +(*****************************************************************************) +(* Normalizers *) +(*****************************************************************************) + + +let structdef_to_struct_name ty = + match ty with + | qu, (StructUnion (su, sopt, fields), iis) -> + (match sopt,iis with + (* todo? but what if correspond to a nested struct def ? *) + | Some s , [i1;i2;i3;i4] -> + qu, (StructUnionName (su, s), [i1;i2]) + | None, _ -> + ty + | x -> raise Impossible + ) + | _ -> raise Impossible + + +(*****************************************************************************) +(* Helpers *) +(*****************************************************************************) + + +let type_of_function (def,ii) = + let ftyp = def.f_type in + + (* could use the info in the 'ii' ? *) + + let fake = Ast_c.fakeInfo (Common.fake_parse_info) in + let fake_oparen = Ast_c.rewrap_str "(" fake in + let fake = Ast_c.fakeInfo (Common.fake_parse_info) in + let fake_cparen = Ast_c.rewrap_str ")" fake in + + Ast_c.nQ, (FunctionType ftyp, [fake_oparen;fake_cparen]) + + +(* pre: only a single variable *) +let type_of_decl decl = + match decl with + | Ast_c.DeclList (xs,ii1) -> + (match xs with + | [] -> raise Impossible + + (* todo? for other xs ? *) + | (x,ii2)::xs -> + let {v_namei = _var; v_type = v_type; + v_storage = (_storage,_inline)} = x in + + (* TODO normalize ? what if nested structure definition ? *) + v_type + ) + | Ast_c.MacroDecl _ -> + pr2_once "not handling MacroDecl type yet"; + raise Todo + + + +(* pre: it is indeed a struct def decl, and only a single variable *) +let structdef_of_decl decl = + + match decl with + | Ast_c.DeclList (xs,ii1) -> + (match xs with + | [] -> raise Impossible + + (* todo? for other xs ? *) + | (x,ii2)::xs -> + let {v_namei = var; v_type = v_type; + v_storage = (storage,inline)} = x in + + (match Ast_c.unwrap_typeC v_type with + | Ast_c.StructUnion (su, _must_be_some, fields) -> + (su, fields) + | _ -> raise Impossible + ) + ) + | Ast_c.MacroDecl _ -> raise Impossible + + + + +(*****************************************************************************) +(* Type builder *) +(*****************************************************************************) + +let (fake_function_type: + fullType option -> argument wrap2 list -> fullType option) = + fun rettype args -> + + let fake = Ast_c.fakeInfo (Common.fake_parse_info) in + let fake_oparen = Ast_c.rewrap_str "(" fake in + let fake = Ast_c.fakeInfo (Common.fake_parse_info) in + let fake_cparen = Ast_c.rewrap_str ")" fake in + + let (tyargs: parameterType wrap2 list) = + args +> Common.map_filter (fun (arg,ii) -> + match arg with + | Left e -> + (match Ast_c.get_onlytype_expr e with + | Some ft -> + let paramtype = + (false, None, ft), [] + in + Some (paramtype, ii) + | None -> None + ) + | Right _ -> None + ) + in + if List.length args <> List.length tyargs + then None + else + rettype +> Common.map_option (fun rettype -> + let (ftyp: functionType) = (rettype, (tyargs, (false,[]))) in + let (t: fullType) = + (Ast_c.nQ, (FunctionType ftyp, [fake_oparen;fake_cparen])) + in + t + ) + + +(*****************************************************************************) +(* Typing rules *) +(*****************************************************************************) + + +(* todo: the rules are far more complex, but I prefer to simplify for now. + * todo: should take operator as a parameter. + * + * todo: Also need handle pointer arithmetic! the type of 'pt + 2' + * is still the type of pt. cf parsing_cocci/type_infer.ml + * + * (* pad: in pointer arithmetic, as in ptr+1, the lub must be ptr *) + * | (T.Pointer(ty1),T.Pointer(ty2)) -> + * T.Pointer(loop(ty1,ty2)) + * | (ty1,T.Pointer(ty2)) -> T.Pointer(ty2) + * | (T.Pointer(ty1),ty2) -> T.Pointer(ty1) + * +*) +let lub t1 t2 = + let ftopt = + match t1, t2 with + | None, None -> None + | Some t, None -> Some t + | None, Some t -> Some t + (* check equal ? no cos can have pointer arithmetic so t2 can be <> t1 + * + * todo: right now I favor the first term because usually pointer + * arithmetic are written with the pointer in the first position. + * + * Also when an expression contain a typedef, as in + * 'dma_addr + 1' where dma_addr was declared as a varialbe + * of type dma_addr_t, then again I want to have in the lub + * the typedef and it is often again in the first position. + * + *) + | Some t1, Some t2 -> + let t1bis = Ast_c.unwrap_typeC t1 in + let t2bis = Ast_c.unwrap_typeC t2 in + (match t1bis, t2bis with + (* todo, Pointer, Typedef, etc *) + | _, _ -> Some t1 + ) + + in + match ftopt with + | None -> None, Ast_c.NotTest + | Some ft -> Some (ft, Ast_c.NotLocalVar), Ast_c.NotTest + + + +(*****************************************************************************) +(* type lookup *) +(*****************************************************************************) + +(* old: was using some nested find_some, but easier use ref + * update: handling union (used a lot in sparse) + * note: it is independent of the environment. +*) +let (type_field: + string -> (Ast_c.structUnion * Ast_c.structType) -> Ast_c.fullType) = + fun fld (su, fields) -> + + let res = ref [] in + + let rec aux_fields fields = + fields +> List.iter (fun x -> + match Ast_c.unwrap x with + | DeclarationField (FieldDeclList (onefield_multivars, iiptvirg)) -> + onefield_multivars +> List.iter (fun fieldkind -> + match Ast_c.unwrap (Ast_c.unwrap fieldkind) with + | Simple (Some s, t) | BitField (Some s, t, _) -> + if s = fld + then Common.push2 t res + else () + + | Simple (None, t) -> + (match Ast_c.unwrap_typeC t with + + (* union *) + | StructUnion (Union, _, fields) -> + aux_fields fields + + (* Special case of nested structure definition inside + * structure without associated field variable as in + * struct top = { ... struct xx { int subfield1; ... }; ... } + * cf sparse source, where can access subfields directly. + * It can also be used in conjunction with union. + *) + | StructUnion (Struct, _, fields) -> + aux_fields fields + + | _ -> () + ) + | _ -> () + ) + + | EmptyField -> () + | MacroStructDeclTodo -> pr2_once "DeclTodo"; () + + | CppDirectiveStruct _ + | IfdefStruct _ -> pr2_once "StructCpp"; + ) + in + aux_fields fields; + match !res with + | [t] -> t + | [] -> + raise Not_found + | x::y::xs -> + pr2 ("MultiFound field: " ^ fld) ; + x + + + diff --git a/parsing_c/type_c.mli b/parsing_c/type_c.mli new file mode 100644 index 0000000..af3b6f0 --- /dev/null +++ b/parsing_c/type_c.mli @@ -0,0 +1,36 @@ + +type finalType = Ast_c.fullType + +(* lookup *) +val type_field: + string -> (Ast_c.structUnion * Ast_c.structType) -> Ast_c.fullType + +(* typing rules *) +val lub: + finalType option -> finalType option -> Ast_c.exp_info + +(* helpers *) +val structdef_to_struct_name: + finalType -> finalType +val fake_function_type: + finalType option -> Ast_c.argument Ast_c.wrap2 list -> finalType option + +(* return normalize types ? *) +val type_of_function: + Ast_c.definition -> finalType +val type_of_decl: + Ast_c.declaration -> finalType +val structdef_of_decl: + Ast_c.declaration -> Ast_c.structUnion * Ast_c.structType + + +(* builders *) +val make_info_def: finalType -> Ast_c.exp_info +val make_info: Ast_c.exp_type -> Ast_c.exp_info + +val noTypeHere: Ast_c.exp_info + +val do_with_type: + (finalType -> Ast_c.exp_info) -> Ast_c.exp_info -> Ast_c.exp_info +val get_opt_type: + Ast_c.expression -> finalType option diff --git a/parsing_c/visitor_c.ml b/parsing_c/visitor_c.ml index 27840f0..2811ebe 100644 --- a/parsing_c/visitor_c.ml +++ b/parsing_c/visitor_c.ml @@ -15,6 +15,14 @@ open Common open Ast_c module F = Control_flow_c +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) + +(* todo? dont go in Include. Have a visitor flag ? disable_go_include ? + * disable_go_type_annotation ? + *) + (*****************************************************************************) (* Functions to visit the Ast, and now also the CFG nodes *) (*****************************************************************************) @@ -162,7 +170,7 @@ let rec vk_expr = fun bigf expr -> let iif ii = vk_ii bigf ii in let rec exprf e = bigf.kexpr (k,bigf) e - (* dont go in _typ *) + (* !!! dont go in _typ !!! *) and k ((e,_typ), ii) = iif ii; match e with @@ -344,22 +352,28 @@ and vk_decl = fun bigf d -> let f = bigf.kdecl in let rec k decl = match decl with - | DeclList (xs,ii) -> iif ii; List.iter aux xs + | DeclList (xs,ii) -> xs +> List.iter (fun (x,ii) -> + iif ii; + vk_onedecl bigf x; + ); | MacroDecl ((s, args),ii) -> iif ii; vk_argument_list bigf args; + in f (k, bigf) d + + +and vk_onedecl = fun bigf onedecl -> + let iif ii = vk_ii bigf ii in + match onedecl with + | ({v_namei = var; v_type = t; + v_storage = _sto; v_attr = attrs}) -> - - and aux ({v_namei = var; v_type = t; - v_storage = _sto; v_attr = attrs}, iicomma) = - iif iicomma; vk_type bigf t; attrs +> List.iter (vk_attribute bigf); var +> do_option (fun ((s, ini), ii_s_ini) -> iif ii_s_ini; ini +> do_option (vk_ini bigf) ); - in f (k, bigf) d and vk_ini = fun bigf ini -> let iif ii = vk_ii bigf ii in @@ -410,7 +424,7 @@ and vk_struct_fields = fun bigf fields -> iif iiptvirg; | EmptyField -> () | MacroStructDeclTodo -> - pr2 "MacroStructDeclTodo"; + pr2_once "MacroStructDeclTodo"; () | CppDirectiveStruct directive -> @@ -446,6 +460,7 @@ and vk_def = fun bigf d -> f_storage = sto; f_body = statxs; f_attr = attrs; + f_old_c_style = oldstyle; }, ii -> iif ii; @@ -456,6 +471,10 @@ and vk_def = fun bigf d -> vk_param bigf param; iif iicomma; ); + oldstyle +> Common.do_option (fun decls -> + decls +> List.iter (vk_decl bigf); + ); + statxs +> List.iter (vk_statement_sequencable bigf) in f (k, bigf) d @@ -499,7 +518,11 @@ and vk_cpp_directive bigf directive = i_content = copt; } -> - (* go inside ? *) + (* go inside ? yes, can be useful, for instance for type_annotater. + * The only pb may be that when we want to unparse the code we + * don't want to unparse the included file but the unparser + * and pretty_print do not use visitor_c so no problem. + *) iif ii; copt +> Common.do_option (fun (file, asts) -> vk_program bigf asts @@ -544,7 +567,7 @@ and vk_define_val bigf defval = | DefineInit ini -> vk_ini bigf ini | DefineTodo -> - pr2 "DefineTodo"; + pr2_once "DefineTodo"; () in f (k, bigf) defval @@ -573,22 +596,9 @@ and vk_node = fun bigf node -> let rec k n = match F.unwrap n with - | F.FunHeader ({f_name =idb; - f_type = (rett, (paramst,(isvaargs,iidotsb))); - f_storage = stob; - f_body = body; - f_attr = attrs},ii) -> - - assert(null body); - iif ii; - iif iidotsb; - attrs +> List.iter (vk_attribute bigf); - vk_type bigf rett; - paramst +> List.iter (fun (param, iicomma) -> - vk_param bigf param; - iif iicomma; - ); - + | F.FunHeader (def) -> + assert(null (fst def).f_body); + vk_def bigf def; | F.Decl decl -> vk_decl bigf decl | F.ExprStatement (st, (eopt, ii)) -> @@ -629,7 +639,7 @@ and vk_node = fun bigf node -> | F.DefineDoWhileZeroHeader (((),ii)) -> iif ii | F.DefineTodo -> - pr2 "DefineTodo"; + pr2_once "DefineTodo"; () @@ -830,7 +840,7 @@ let rec vk_expr_s = fun bigf expr -> let rec exprf e = bigf.kexpr_s (k, bigf) e and k e = let ((unwrap_e, typ), ii) = e in - (* don't analyse optional type + (* !!! don't analyse optional type !!! * old: typ +> map_option (vk_type_s bigf) in *) let typ' = typ in @@ -1156,7 +1166,7 @@ and vk_struct_fields_s = fun bigf fields -> (vk_struct_fieldkinds_s bigf onefield_multivars, iif iiptvirg)) | EmptyField -> EmptyField | MacroStructDeclTodo -> - pr2 "MacroStructDeclTodo"; + pr2_once "MacroStructDeclTodo"; MacroStructDeclTodo | CppDirectiveStruct directive -> @@ -1178,6 +1188,7 @@ and vk_def_s = fun bigf d -> f_storage = sto; f_body = statxs; f_attr = attrs; + f_old_c_style = oldstyle; }, ii -> {f_name = s; @@ -1190,7 +1201,11 @@ and vk_def_s = fun bigf d -> f_body = vk_statement_sequencable_list_s bigf statxs; f_attr = - attrs +> List.map (vk_attribute_s bigf) + attrs +> List.map (vk_attribute_s bigf); + f_old_c_style = + oldstyle +> Common.map_option (fun decls -> + decls +> List.map (vk_decl_s bigf) + ); }, iif ii @@ -1286,7 +1301,7 @@ and vk_define_val_s = fun bigf x -> | DefineInit ini -> DefineInit (vk_ini_s bigf ini) | DefineTodo -> - pr2 "DefineTodo"; + pr2_once "DefineTodo"; DefineTodo in f (k, bigf) x @@ -1310,28 +1325,9 @@ and vk_node_s = fun bigf node -> and k node = F.rewrap node ( match F.unwrap node with - | F.FunHeader ({f_name = idb; - f_type =(rett, (paramst,(isvaargs,iidotsb))); - f_storage = stob; - f_body = body; - f_attr = attrs; - },ii) -> - assert(null body); - - F.FunHeader - ({f_name =idb; - f_type = - (vk_type_s bigf rett, - (paramst +> List.map (fun (param, iicomma) -> - (vk_param_s bigf param, iif iicomma) - ), (isvaargs,iif iidotsb))); - f_storage = stob; - f_body = body; - f_attr = - attrs +> List.map (vk_attribute_s bigf) - }, - iif ii) - + | F.FunHeader (def) -> + assert (null (fst def).f_body); + F.FunHeader (vk_def_s bigf def) | F.Decl declb -> F.Decl (vk_decl_s bigf declb) | F.ExprStatement (st, (eopt, ii)) -> diff --git a/parsing_c/visitor_c.mli b/parsing_c/visitor_c.mli index 197c1d1..361a096 100644 --- a/parsing_c/visitor_c.mli +++ b/parsing_c/visitor_c.mli @@ -22,6 +22,7 @@ val vk_expr : visitor_c -> expression -> unit val vk_statement : visitor_c -> statement -> unit val vk_type : visitor_c -> fullType -> unit val vk_decl : visitor_c -> declaration -> unit +val vk_onedecl : visitor_c -> onedecl -> unit val vk_ini : visitor_c -> initialiser -> unit val vk_def : visitor_c -> definition -> unit val vk_node : visitor_c -> Control_flow_c.node -> unit @@ -78,6 +79,7 @@ val vk_ini_s : visitor_c_s -> initialiser -> initialiser val vk_def_s : visitor_c_s -> definition -> definition val vk_toplevel_s : visitor_c_s -> toplevel -> toplevel val vk_info_s : visitor_c_s -> info -> info +val vk_ii_s : visitor_c_s -> info list -> info list val vk_node_s : visitor_c_s -> Control_flow_c.node -> Control_flow_c.node val vk_program_s : visitor_c_s -> program -> program diff --git a/parsing_cocci/.#iso_pattern.ml.1.144 b/parsing_cocci/.#iso_pattern.ml.1.144 new file mode 100644 index 0000000..6b6875d --- /dev/null +++ b/parsing_cocci/.#iso_pattern.ml.1.144 @@ -0,0 +1,2334 @@ +(* +* Copyright 2005-2008, Ecole des Mines de Nantes, University of Copenhagen +* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller +* This file is part of Coccinelle. +* +* Coccinelle is free software: you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation, according to version 2 of the License. +* +* Coccinelle is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with Coccinelle. If not, see . +* +* The authors reserve the right to distribute this or future versions of +* Coccinelle under other licenses. +*) + + +(* Potential problem: offset of mcode is not updated when an iso is +instantiated, implying that a term may end up with many mcodes with the +same offset. On the other hand, at the moment offset only seems to be used +before this phase. Furthermore add_dot_binding relies on the offset to +remain the same between matching an iso and instantiating it with bindings. *) + +(* --------------------------------------------------------------------- *) +(* match a SmPL expression against a SmPL abstract syntax tree, +either - or + *) + +module Ast = Ast_cocci +module Ast0 = Ast0_cocci +module V0 = Visitor_ast0 + +let current_rule = ref "" + +(* --------------------------------------------------------------------- *) + +type isomorphism = + Ast_cocci.metavar list * Ast0_cocci.anything list list * string (* name *) + +let strip_info = + let mcode (term,_,_,_,_) = + (term,Ast0.NONE,Ast0.default_info(),Ast0.PLUS,ref Ast0.NoMetaPos) in + let donothing r k e = + let x = k e in + {(Ast0.wrap (Ast0.unwrap x)) with + Ast0.mcodekind = ref Ast0.PLUS; + Ast0.true_if_test = x.Ast0.true_if_test} in + V0.rebuilder + mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode + mcode + donothing donothing donothing donothing donothing donothing + donothing donothing donothing donothing donothing donothing donothing + donothing donothing + +let anything_equal = function + (Ast0.DotsExprTag(d1),Ast0.DotsExprTag(d2)) -> + failwith "not a possible variable binding" (*not sure why these are pbs*) + | (Ast0.DotsInitTag(d1),Ast0.DotsInitTag(d2)) -> + failwith "not a possible variable binding" + | (Ast0.DotsParamTag(d1),Ast0.DotsParamTag(d2)) -> + failwith "not a possible variable binding" + | (Ast0.DotsStmtTag(d1),Ast0.DotsStmtTag(d2)) -> + (strip_info.V0.rebuilder_statement_dots d1) = + (strip_info.V0.rebuilder_statement_dots d2) + | (Ast0.DotsDeclTag(d1),Ast0.DotsDeclTag(d2)) -> + failwith "not a possible variable binding" + | (Ast0.DotsCaseTag(d1),Ast0.DotsCaseTag(d2)) -> + failwith "not a possible variable binding" + | (Ast0.IdentTag(d1),Ast0.IdentTag(d2)) -> + (strip_info.V0.rebuilder_ident d1) = (strip_info.V0.rebuilder_ident d2) + | (Ast0.ExprTag(d1),Ast0.ExprTag(d2)) -> + (strip_info.V0.rebuilder_expression d1) = + (strip_info.V0.rebuilder_expression d2) + | (Ast0.ArgExprTag(_),_) | (_,Ast0.ArgExprTag(_)) -> + failwith "not possible - only in isos1" + | (Ast0.TestExprTag(_),_) | (_,Ast0.TestExprTag(_)) -> + failwith "not possible - only in isos1" + | (Ast0.TypeCTag(d1),Ast0.TypeCTag(d2)) -> + (strip_info.V0.rebuilder_typeC d1) = + (strip_info.V0.rebuilder_typeC d2) + | (Ast0.InitTag(d1),Ast0.InitTag(d2)) -> + (strip_info.V0.rebuilder_initialiser d1) = + (strip_info.V0.rebuilder_initialiser d2) + | (Ast0.ParamTag(d1),Ast0.ParamTag(d2)) -> + (strip_info.V0.rebuilder_parameter d1) = + (strip_info.V0.rebuilder_parameter d2) + | (Ast0.DeclTag(d1),Ast0.DeclTag(d2)) -> + (strip_info.V0.rebuilder_declaration d1) = + (strip_info.V0.rebuilder_declaration d2) + | (Ast0.StmtTag(d1),Ast0.StmtTag(d2)) -> + (strip_info.V0.rebuilder_statement d1) = + (strip_info.V0.rebuilder_statement d2) + | (Ast0.CaseLineTag(d1),Ast0.CaseLineTag(d2)) -> + (strip_info.V0.rebuilder_case_line d1) = + (strip_info.V0.rebuilder_case_line d2) + | (Ast0.TopTag(d1),Ast0.TopTag(d2)) -> + (strip_info.V0.rebuilder_top_level d1) = + (strip_info.V0.rebuilder_top_level d2) + | (Ast0.IsoWhenTTag(_),_) | (_,Ast0.IsoWhenTTag(_)) -> + failwith "only for isos within iso phase" + | (Ast0.IsoWhenFTag(_),_) | (_,Ast0.IsoWhenFTag(_)) -> + failwith "only for isos within iso phase" + | (Ast0.IsoWhenTag(_),_) | (_,Ast0.IsoWhenTag(_)) -> + failwith "only for isos within iso phase" + | _ -> false + +let term (var1,_,_,_,_) = var1 +let dot_term (var1,_,info,_,_) = ("", var1 ^ (string_of_int info.Ast0.offset)) + + +type reason = + NotPure of Ast0.pure * (string * string) * Ast0.anything + | NotPureLength of (string * string) + | ContextRequired of Ast0.anything + | NonMatch + | Braces of Ast0.statement + | Position of string * string + | TypeMatch of reason list + +let rec interpret_reason name line reason printer = + Printf.printf + "warning: iso %s does not match the code below on line %d\n" name line; + printer(); Format.print_newline(); + match reason with + NotPure(Ast0.Pure,(_,var),nonpure) -> + Printf.printf + "pure metavariable %s is matched against the following nonpure code:\n" + var; + Unparse_ast0.unparse_anything nonpure + | NotPure(Ast0.Context,(_,var),nonpure) -> + Printf.printf + "context metavariable %s is matched against the following\nnoncontext code:\n" + var; + Unparse_ast0.unparse_anything nonpure + | NotPure(Ast0.PureContext,(_,var),nonpure) -> + Printf.printf + "pure context metavariable %s is matched against the following\nnonpure or noncontext code:\n" + var; + Unparse_ast0.unparse_anything nonpure + | NotPureLength((_,var)) -> + Printf.printf + "pure metavariable %s is matched against too much or too little code\n" + var; + | ContextRequired(term) -> + Printf.printf + "the following code matched is not uniformly minus or context,\nor contains a disjunction:\n"; + Unparse_ast0.unparse_anything term + | Braces(s) -> + Printf.printf "braces must be all minus (plus code allowed) or all\ncontext (plus code not allowed in the body) to match:\n"; + Unparse_ast0.statement "" s; + Format.print_newline() + | Position(rule,name) -> + Printf.printf "position variable %s.%s conflicts with an isomorphism\n" + rule name; + | TypeMatch reason_list -> + List.iter (function r -> interpret_reason name line r printer) + reason_list + | _ -> failwith "not possible" + +type 'a either = OK of 'a | Fail of reason + +let add_binding var exp bindings = + let var = term var in + let attempt bindings = + try + let cur = List.assoc var bindings in + if anything_equal(exp,cur) then [bindings] else [] + with Not_found -> [((var,exp)::bindings)] in + match List.concat(List.map attempt bindings) with + [] -> Fail NonMatch + | x -> OK x + +let add_dot_binding var exp bindings = + let var = dot_term var in + let attempt bindings = + try + let cur = List.assoc var bindings in + if anything_equal(exp,cur) then [bindings] else [] + with Not_found -> [((var,exp)::bindings)] in + match List.concat(List.map attempt bindings) with + [] -> Fail NonMatch + | x -> OK x + +(* multi-valued *) +let add_multi_dot_binding var exp bindings = + let var = dot_term var in + let attempt bindings = [((var,exp)::bindings)] in + match List.concat(List.map attempt bindings) with + [] -> Fail NonMatch + | x -> OK x + +let rec nub ls = + match ls with + [] -> [] + | (x::xs) when (List.mem x xs) -> nub xs + | (x::xs) -> x::(nub xs) + +(* --------------------------------------------------------------------- *) + +let init_env = [[]] + +let debug str m binding = + let res = m binding in + (match res with + None -> Printf.printf "%s: failed\n" str + | Some binding -> + List.iter + (function binding -> + Printf.printf "%s: %s\n" str + (String.concat " " (List.map (function (x,_) -> x) binding))) + binding); + res + +let conjunct_bindings + (m1 : 'binding -> 'binding either) + (m2 : 'binding -> 'binding either) + (binding : 'binding) : 'binding either = + match m1 binding with Fail(reason) -> Fail(reason) | OK binding -> m2 binding + +let rec conjunct_many_bindings = function + [] -> failwith "not possible" + | [x] -> x + | x::xs -> conjunct_bindings x (conjunct_many_bindings xs) + +let mcode_equal (x,_,_,_,_) (y,_,_,_,_) = x = y + +let return b binding = if b then OK binding else Fail NonMatch +let return_false reason binding = Fail reason + +let match_option f t1 t2 = + match (t1,t2) with + (Some t1, Some t2) -> f t1 t2 + | (None, None) -> return true + | _ -> return false + +let bool_match_option f t1 t2 = + match (t1,t2) with + (Some t1, Some t2) -> f t1 t2 + | (None, None) -> true + | _ -> false + +(* context_required is for the example + if ( ++ (int * ) + x == NULL) + where we can't change x == NULL to eg NULL == x. So there can either be + nothing attached to the root or the term has to be all removed. + if would be nice if we knew more about the relationship between the - and + + code, because in the case where the + code is a separate statement in a + sequence, this is not a problem. Perhaps something could be done in + insert_plus + + The example seems strange. Why isn't the cast attached to x? + *) +let is_context e = + !Flag.sgrep_mode2 or (* everything is context for sgrep *) + (match Ast0.get_mcodekind e with + Ast0.CONTEXT(cell) -> true + | _ -> false) + +(* needs a special case when there is a Disj or an empty DOTS + the following stops at the statement level, and gives true if one + statement is replaced by another *) +let rec is_pure_context s = + !Flag.sgrep_mode2 or (* everything is context for sgrep *) + (match Ast0.unwrap s with + Ast0.Disj(starter,statement_dots_list,mids,ender) -> + List.for_all + (function x -> + match Ast0.undots x with + [s] -> is_pure_context s + | _ -> false (* could we do better? *)) + statement_dots_list + | _ -> + (match Ast0.get_mcodekind s with + Ast0.CONTEXT(mc) -> + (match !mc with + (Ast.NOTHING,_,_) -> true + | _ -> false) + | Ast0.MINUS(mc) -> + (match !mc with + (* do better for the common case of replacing a stmt by another one *) + ([[Ast.StatementTag(s)]],_) -> + (match Ast.unwrap s with + Ast.IfThen(_,_,_) -> false (* potentially dangerous *) + | _ -> true) + | (_,_) -> false) + | _ -> false)) + +let is_minus e = + match Ast0.get_mcodekind e with Ast0.MINUS(cell) -> true | _ -> false + +let match_list matcher is_list_matcher do_list_match la lb = + let rec loop = function + ([],[]) -> return true + | ([x],lb) when is_list_matcher x -> do_list_match x lb + | (x::xs,y::ys) -> conjunct_bindings (matcher x y) (loop (xs,ys)) + | _ -> return false in + loop (la,lb) + +let match_maker checks_needed context_required whencode_allowed = + + let check_mcode pmc cmc binding = + if checks_needed + then + match Ast0.get_pos cmc with + (Ast0.MetaPos (name,_,_)) as x -> + (match Ast0.get_pos pmc with + Ast0.MetaPos (name1,_,_) -> + add_binding name1 (Ast0.MetaPosTag x) binding + | Ast0.NoMetaPos -> + let (rule,name) = Ast0.unwrap_mcode name in + Fail (Position(rule,name))) + | Ast0.NoMetaPos -> OK binding + else OK binding in + + let match_dots matcher is_list_matcher do_list_match d1 d2 = + match (Ast0.unwrap d1, Ast0.unwrap d2) with + (Ast0.DOTS(la),Ast0.DOTS(lb)) + | (Ast0.CIRCLES(la),Ast0.CIRCLES(lb)) + | (Ast0.STARS(la),Ast0.STARS(lb)) -> + match_list matcher is_list_matcher (do_list_match d2) la lb + | _ -> return false in + + let is_elist_matcher el = + match Ast0.unwrap el with Ast0.MetaExprList(_,_,_) -> true | _ -> false in + + let is_plist_matcher pl = + match Ast0.unwrap pl with Ast0.MetaParamList(_,_,_) -> true | _ -> false in + + let is_slist_matcher pl = + match Ast0.unwrap pl with Ast0.MetaStmtList(_,_) -> true | _ -> false in + + let no_list _ = false in + + let build_dots pattern data = + match Ast0.unwrap pattern with + Ast0.DOTS(_) -> Ast0.rewrap pattern (Ast0.DOTS(data)) + | Ast0.CIRCLES(_) -> Ast0.rewrap pattern (Ast0.CIRCLES(data)) + | Ast0.STARS(_) -> Ast0.rewrap pattern (Ast0.STARS(data)) in + + let pure_sp_code = + let bind = Ast0.lub_pure in + let option_default = Ast0.Context in + let pure_mcodekind mc = + if !Flag.sgrep_mode2 + then Ast0.PureContext + else + match mc with + Ast0.CONTEXT(mc) -> + (match !mc with + (Ast.NOTHING,_,_) -> Ast0.PureContext + | _ -> Ast0.Context) + | Ast0.MINUS(mc) -> + (match !mc with ([],_) -> Ast0.Pure | _ -> Ast0.Impure) + | _ -> Ast0.Impure in + let donothing r k e = + bind (pure_mcodekind (Ast0.get_mcodekind e)) (k e) in + + let mcode m = pure_mcodekind (Ast0.get_mcode_mcodekind m) in + + (* a case for everything that has a metavariable *) + (* pure is supposed to match only unitary metavars, not anything that + contains only unitary metavars *) + let ident r k i = + bind (bind (pure_mcodekind (Ast0.get_mcodekind i)) (k i)) + (match Ast0.unwrap i with + Ast0.MetaId(name,_,pure) | Ast0.MetaFunc(name,_,pure) + | Ast0.MetaLocalFunc(name,_,pure) -> pure + | _ -> Ast0.Impure) in + + let expression r k e = + bind (bind (pure_mcodekind (Ast0.get_mcodekind e)) (k e)) + (match Ast0.unwrap e with + Ast0.MetaErr(name,_,pure) + | Ast0.MetaExpr(name,_,_,_,pure) | Ast0.MetaExprList(name,_,pure) -> + pure + | _ -> Ast0.Impure) in + + let typeC r k t = + bind (bind (pure_mcodekind (Ast0.get_mcodekind t)) (k t)) + (match Ast0.unwrap t with + Ast0.MetaType(name,pure) -> pure + | _ -> Ast0.Impure) in + + let param r k p = + bind (bind (pure_mcodekind (Ast0.get_mcodekind p)) (k p)) + (match Ast0.unwrap p with + Ast0.MetaParam(name,pure) | Ast0.MetaParamList(name,_,pure) -> pure + | _ -> Ast0.Impure) in + + let stmt r k s = + bind (bind (pure_mcodekind (Ast0.get_mcodekind s)) (k s)) + (match Ast0.unwrap s with + Ast0.MetaStmt(name,pure) | Ast0.MetaStmtList(name,pure) -> pure + | _ -> Ast0.Impure) in + + V0.combiner bind option_default + mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode + mcode + donothing donothing donothing donothing donothing donothing + ident expression typeC donothing param donothing stmt donothing + donothing in + + let add_pure_list_binding name pure is_pure builder1 builder2 lst = + match (checks_needed,pure) with + (true,Ast0.Pure) | (true,Ast0.Context) | (true,Ast0.PureContext) -> + (match lst with + [x] -> + if (Ast0.lub_pure (is_pure x) pure) = pure + then add_binding name (builder1 lst) + else return_false (NotPure (pure,term name,builder1 lst)) + | _ -> return_false (NotPureLength (term name))) + | (false,_) | (_,Ast0.Impure) -> add_binding name (builder2 lst) in + + let add_pure_binding name pure is_pure builder x = + match (checks_needed,pure) with + (true,Ast0.Pure) | (true,Ast0.Context) | (true,Ast0.PureContext) -> + if (Ast0.lub_pure (is_pure x) pure) = pure + then add_binding name (builder x) + else return_false (NotPure (pure,term name, builder x)) + | (false,_) | (_,Ast0.Impure) -> add_binding name (builder x) in + + let do_elist_match builder el lst = + match Ast0.unwrap el with + Ast0.MetaExprList(name,lenname,pure) -> + (*how to handle lenname? should it be an option type and always None?*) + failwith "expr list pattern not supported in iso" + (*add_pure_list_binding name pure + pure_sp_code.V0.combiner_expression + (function lst -> Ast0.ExprTag(List.hd lst)) + (function lst -> Ast0.DotsExprTag(build_dots builder lst)) + lst*) + | _ -> failwith "not possible" in + + let do_plist_match builder pl lst = + match Ast0.unwrap pl with + Ast0.MetaParamList(name,lename,pure) -> + failwith "param list pattern not supported in iso" + (*add_pure_list_binding name pure + pure_sp_code.V0.combiner_parameter + (function lst -> Ast0.ParamTag(List.hd lst)) + (function lst -> Ast0.DotsParamTag(build_dots builder lst)) + lst*) + | _ -> failwith "not possible" in + + let do_slist_match builder sl lst = + match Ast0.unwrap sl with + Ast0.MetaStmtList(name,pure) -> + add_pure_list_binding name pure + pure_sp_code.V0.combiner_statement + (function lst -> Ast0.StmtTag(List.hd lst)) + (function lst -> Ast0.DotsStmtTag(build_dots builder lst)) + lst + | _ -> failwith "not possible" in + + let do_nolist_match _ _ = failwith "not possible" in + + let rec match_ident pattern id = + match Ast0.unwrap pattern with + Ast0.MetaId(name,_,pure) -> + (add_pure_binding name pure pure_sp_code.V0.combiner_ident + (function id -> Ast0.IdentTag id) id) + | Ast0.MetaFunc(name,_,pure) -> failwith "metafunc not supported" + | Ast0.MetaLocalFunc(name,_,pure) -> failwith "metalocalfunc not supported" + | up -> + if not(checks_needed) or not(context_required) or is_context id + then + match (up,Ast0.unwrap id) with + (Ast0.Id(namea),Ast0.Id(nameb)) -> + if mcode_equal namea nameb + then check_mcode namea nameb + else return false + | (Ast0.OptIdent(ida),Ast0.OptIdent(idb)) + | (Ast0.UniqueIdent(ida),Ast0.UniqueIdent(idb)) -> + match_ident ida idb + | (_,Ast0.OptIdent(idb)) + | (_,Ast0.UniqueIdent(idb)) -> match_ident pattern idb + | _ -> return false + else return_false (ContextRequired (Ast0.IdentTag id)) in + + (* should we do something about matching metavars against ...? *) + let rec match_expr pattern expr = + match Ast0.unwrap pattern with + Ast0.MetaExpr(name,_,ty,form,pure) -> + let form_ok = + match (form,expr) with + (Ast.ANY,_) -> true + | (Ast.CONST,e) -> + let rec matches e = + match Ast0.unwrap e with + Ast0.Constant(c) -> true + | Ast0.Cast(lp,ty,rp,e) -> matches e + | Ast0.SizeOfExpr(se,exp) -> true + | Ast0.SizeOfType(se,lp,ty,rp) -> true + | Ast0.MetaExpr(nm,_,_,Ast.CONST,p) -> + (Ast0.lub_pure p pure) = pure + | _ -> false in + matches e + | (Ast.ID,e) | (Ast.LocalID,e) -> + let rec matches e = + match Ast0.unwrap e with + Ast0.Ident(c) -> true + | Ast0.Cast(lp,ty,rp,e) -> matches e + | Ast0.MetaExpr(nm,_,_,Ast.ID,p) -> + (Ast0.lub_pure p pure) = pure + | _ -> false in + matches e in + if form_ok + then + match ty with + Some ts -> + if List.exists + (function Type_cocci.MetaType(_,_,_) -> true | _ -> false) + ts + then + (match ts with + [Type_cocci.MetaType(tyname,_,_)] -> + let expty = + match (Ast0.unwrap expr,Ast0.get_type expr) with + (* easier than updating type inferencer to manage multiple + types *) + (Ast0.MetaExpr(_,_,Some tts,_,_),_) -> Some tts + | (_,Some ty) -> Some [ty] + | _ -> None in + (match expty with + Some expty -> + let tyname = Ast0.rewrap_mcode name tyname in + conjunct_bindings + (add_pure_binding name pure + pure_sp_code.V0.combiner_expression + (function expr -> Ast0.ExprTag expr) + expr) + (function bindings -> + let attempts = + List.map + (function expty -> + (try + add_pure_binding tyname Ast0.Impure + (function _ -> Ast0.Impure) + (function ty -> Ast0.TypeCTag ty) + (Ast0.rewrap expr + (Ast0.reverse_type expty)) + bindings + with Ast0.TyConv -> + Printf.printf + "warning: unconvertible type"; + return false bindings)) + expty in + if List.exists + (function Fail _ -> false | OK x -> true) + attempts + then + (* not sure why this is ok. can there be more + than one OK? *) + OK (List.concat + (List.map + (function Fail _ -> [] | OK x -> x) + attempts)) + else + Fail + (TypeMatch + (List.map + (function + Fail r -> r + | OK x -> failwith "not possible") + attempts))) + | _ -> + (*Printf.printf + "warning: type metavar can only match one type";*) + return false) + | _ -> + failwith + "mixture of metatype and other types not supported") + else + let expty = Ast0.get_type expr in + if List.exists (function t -> Type_cocci.compatible t expty) ts + then + add_pure_binding name pure + pure_sp_code.V0.combiner_expression + (function expr -> Ast0.ExprTag expr) + expr + else return false + | None -> + add_pure_binding name pure pure_sp_code.V0.combiner_expression + (function expr -> Ast0.ExprTag expr) + expr + else return false + | Ast0.MetaErr(namea,_,pure) -> failwith "metaerr not supported" + | Ast0.MetaExprList(_,_,_) -> failwith "metaexprlist not supported" + | up -> + if not(checks_needed) or not(context_required) or is_context expr + then + match (up,Ast0.unwrap expr) with + (Ast0.Ident(ida),Ast0.Ident(idb)) -> + match_ident ida idb + | (Ast0.Constant(consta),Ast0.Constant(constb)) -> + if mcode_equal consta constb + then check_mcode consta constb + else return false + | (Ast0.FunCall(fna,lp1,argsa,rp1),Ast0.FunCall(fnb,lp,argsb,rp)) -> + conjunct_many_bindings + [check_mcode lp1 lp; check_mcode rp1 rp; match_expr fna fnb; + match_dots match_expr is_elist_matcher do_elist_match + argsa argsb] + | (Ast0.Assignment(lefta,opa,righta,_), + Ast0.Assignment(leftb,opb,rightb,_)) -> + if mcode_equal opa opb + then + conjunct_many_bindings + [check_mcode opa opb; match_expr lefta leftb; + match_expr righta rightb] + else return false + | (Ast0.CondExpr(exp1a,lp1,exp2a,rp1,exp3a), + Ast0.CondExpr(exp1b,lp,exp2b,rp,exp3b)) -> + conjunct_many_bindings + [check_mcode lp1 lp; check_mcode rp1 rp; + match_expr exp1a exp1b; match_option match_expr exp2a exp2b; + match_expr exp3a exp3b] + | (Ast0.Postfix(expa,opa),Ast0.Postfix(expb,opb)) -> + if mcode_equal opa opb + then + conjunct_bindings (check_mcode opa opb) (match_expr expa expb) + else return false + | (Ast0.Infix(expa,opa),Ast0.Infix(expb,opb)) -> + if mcode_equal opa opb + then + conjunct_bindings (check_mcode opa opb) (match_expr expa expb) + else return false + | (Ast0.Unary(expa,opa),Ast0.Unary(expb,opb)) -> + if mcode_equal opa opb + then + conjunct_bindings (check_mcode opa opb) (match_expr expa expb) + else return false + | (Ast0.Binary(lefta,opa,righta),Ast0.Binary(leftb,opb,rightb)) -> + if mcode_equal opa opb + then + conjunct_many_bindings + [check_mcode opa opb; match_expr lefta leftb; + match_expr righta rightb] + else return false + | (Ast0.Paren(lp1,expa,rp1),Ast0.Paren(lp,expb,rp)) -> + conjunct_many_bindings + [check_mcode lp1 lp; check_mcode rp1 rp; match_expr expa expb] + | (Ast0.ArrayAccess(exp1a,lb1,exp2a,rb1), + Ast0.ArrayAccess(exp1b,lb,exp2b,rb)) -> + conjunct_many_bindings + [check_mcode lb1 lb; check_mcode rb1 rb; + match_expr exp1a exp1b; match_expr exp2a exp2b] + | (Ast0.RecordAccess(expa,opa,fielda), + Ast0.RecordAccess(expb,op,fieldb)) + | (Ast0.RecordPtAccess(expa,opa,fielda), + Ast0.RecordPtAccess(expb,op,fieldb)) -> + conjunct_many_bindings + [check_mcode opa op; match_expr expa expb; + match_ident fielda fieldb] + | (Ast0.Cast(lp1,tya,rp1,expa),Ast0.Cast(lp,tyb,rp,expb)) -> + conjunct_many_bindings + [check_mcode lp1 lp; check_mcode rp1 rp; + match_typeC tya tyb; match_expr expa expb] + | (Ast0.SizeOfExpr(szf1,expa),Ast0.SizeOfExpr(szf,expb)) -> + conjunct_bindings (check_mcode szf1 szf) (match_expr expa expb) + | (Ast0.SizeOfType(szf1,lp1,tya,rp1), + Ast0.SizeOfType(szf,lp,tyb,rp)) -> + conjunct_many_bindings + [check_mcode lp1 lp; check_mcode rp1 rp; + check_mcode szf1 szf; match_typeC tya tyb] + | (Ast0.TypeExp(tya),Ast0.TypeExp(tyb)) -> + match_typeC tya tyb + | (Ast0.EComma(cm1),Ast0.EComma(cm)) -> check_mcode cm1 cm + | (Ast0.DisjExpr(_,expsa,_,_),_) -> + failwith "not allowed in the pattern of an isomorphism" + | (Ast0.NestExpr(_,exp_dotsa,_,_,_),_) -> + failwith "not allowed in the pattern of an isomorphism" + | (Ast0.Edots(d,None),Ast0.Edots(d1,None)) + | (Ast0.Ecircles(d,None),Ast0.Ecircles(d1,None)) + | (Ast0.Estars(d,None),Ast0.Estars(d1,None)) -> check_mcode d d1 + | (Ast0.Edots(ed,None),Ast0.Edots(ed1,Some wc)) + | (Ast0.Ecircles(ed,None),Ast0.Ecircles(ed1,Some wc)) + | (Ast0.Estars(ed,None),Ast0.Estars(ed1,Some wc)) -> + (* hope that mcode of edots is unique somehow *) + conjunct_bindings (check_mcode ed ed1) + (let (edots_whencode_allowed,_,_) = whencode_allowed in + if edots_whencode_allowed + then add_dot_binding ed (Ast0.ExprTag wc) + else + (Printf.printf + "warning: not applying iso because of whencode"; + return false)) + | (Ast0.Edots(_,Some _),_) | (Ast0.Ecircles(_,Some _),_) + | (Ast0.Estars(_,Some _),_) -> + failwith "whencode not allowed in a pattern1" + | (Ast0.OptExp(expa),Ast0.OptExp(expb)) + | (Ast0.UniqueExp(expa),Ast0.UniqueExp(expb)) -> match_expr expa expb + | (_,Ast0.OptExp(expb)) + | (_,Ast0.UniqueExp(expb)) -> match_expr pattern expb + | _ -> return false + else return_false (ContextRequired (Ast0.ExprTag expr)) + +(* the special case for function types prevents the eg T X; -> T X = E; iso + from applying, which doesn't seem very relevant, but it also avoids a + mysterious bug that is obtained with eg int attach(...); *) + and match_typeC pattern t = + match Ast0.unwrap pattern with + Ast0.MetaType(name,pure) -> + (match Ast0.unwrap t with + Ast0.FunctionType(tya,lp1a,paramsa,rp1a) -> return false + | _ -> + add_pure_binding name pure pure_sp_code.V0.combiner_typeC + (function ty -> Ast0.TypeCTag ty) + t) + | up -> + if not(checks_needed) or not(context_required) or is_context t + then + match (up,Ast0.unwrap t) with + (Ast0.ConstVol(cva,tya),Ast0.ConstVol(cvb,tyb)) -> + if mcode_equal cva cvb + then + conjunct_bindings (check_mcode cva cvb) (match_typeC tya tyb) + else return false + | (Ast0.BaseType(tya,signa),Ast0.BaseType(tyb,signb)) -> + if (mcode_equal tya tyb && + bool_match_option mcode_equal signa signb) + then + conjunct_bindings (check_mcode tya tyb) + (match_option check_mcode signa signb) + else return false + | (Ast0.ImplicitInt(signa),Ast0.ImplicitInt(signb)) -> + if mcode_equal signa signb + then check_mcode signa signb + else return false + | (Ast0.Pointer(tya,star1),Ast0.Pointer(tyb,star)) -> + conjunct_bindings (check_mcode star1 star) (match_typeC tya tyb) + | (Ast0.FunctionPointer(tya,lp1a,stara,rp1a,lp2a,paramsa,rp2a), + Ast0.FunctionPointer(tyb,lp1b,starb,rp1b,lp2b,paramsb,rp2b)) -> + conjunct_many_bindings + [check_mcode stara starb; check_mcode lp1a lp1b; + check_mcode rp1a rp1b; check_mcode lp2a lp2b; + check_mcode rp2a rp2b; match_typeC tya tyb; + match_dots match_param is_plist_matcher + do_plist_match paramsa paramsb] + | (Ast0.FunctionType(tya,lp1a,paramsa,rp1a), + Ast0.FunctionType(tyb,lp1b,paramsb,rp1b)) -> + conjunct_many_bindings + [check_mcode lp1a lp1b; check_mcode rp1a rp1b; + match_option match_typeC tya tyb; + match_dots match_param is_plist_matcher do_plist_match + paramsa paramsb] + | (Ast0.Array(tya,lb1,sizea,rb1),Ast0.Array(tyb,lb,sizeb,rb)) -> + conjunct_many_bindings + [check_mcode lb1 lb; check_mcode rb1 rb; + match_typeC tya tyb; match_option match_expr sizea sizeb] + | (Ast0.StructUnionName(kinda,Some namea), + Ast0.StructUnionName(kindb,Some nameb)) -> + if mcode_equal kinda kindb + then + conjunct_bindings (check_mcode kinda kindb) + (match_ident namea nameb) + else return false + | (Ast0.StructUnionDef(tya,lb1,declsa,rb1), + Ast0.StructUnionDef(tyb,lb,declsb,rb)) -> + conjunct_many_bindings + [check_mcode lb1 lb; check_mcode rb1 rb; + match_typeC tya tyb; + match_dots match_decl no_list do_nolist_match declsa declsb] + | (Ast0.TypeName(namea),Ast0.TypeName(nameb)) -> + if mcode_equal namea nameb + then check_mcode namea nameb + else return false + | (Ast0.DisjType(_,typesa,_,_),Ast0.DisjType(_,typesb,_,_)) -> + failwith "not allowed in the pattern of an isomorphism" + | (Ast0.OptType(tya),Ast0.OptType(tyb)) + | (Ast0.UniqueType(tya),Ast0.UniqueType(tyb)) -> match_typeC tya tyb + | (_,Ast0.OptType(tyb)) + | (_,Ast0.UniqueType(tyb)) -> match_typeC pattern tyb + | _ -> return false + else return_false (ContextRequired (Ast0.TypeCTag t)) + + and match_decl pattern d = + if not(checks_needed) or not(context_required) or is_context d + then + match (Ast0.unwrap pattern,Ast0.unwrap d) with + (Ast0.Init(stga,tya,ida,eq1,inia,sc1), + Ast0.Init(stgb,tyb,idb,eq,inib,sc)) -> + if bool_match_option mcode_equal stga stgb + then + conjunct_many_bindings + [check_mcode eq1 eq; check_mcode sc1 sc; + match_option check_mcode stga stgb; + match_typeC tya tyb; match_ident ida idb; + match_init inia inib] + else return false + | (Ast0.UnInit(stga,tya,ida,sc1),Ast0.UnInit(stgb,tyb,idb,sc)) -> + if bool_match_option mcode_equal stga stgb + then + conjunct_many_bindings + [check_mcode sc1 sc; match_option check_mcode stga stgb; + match_typeC tya tyb; match_ident ida idb] + else return false + | (Ast0.MacroDecl(namea,lp1,argsa,rp1,sc1), + Ast0.MacroDecl(nameb,lp,argsb,rp,sc)) -> + conjunct_many_bindings + [match_ident namea nameb; + check_mcode lp1 lp; check_mcode rp1 rp; + check_mcode sc1 sc; + match_dots match_expr is_elist_matcher do_elist_match + argsa argsb] + | (Ast0.TyDecl(tya,sc1),Ast0.TyDecl(tyb,sc)) -> + conjunct_bindings (check_mcode sc1 sc) (match_typeC tya tyb) + | (Ast0.Typedef(stga,tya,ida,sc1),Ast0.Typedef(stgb,tyb,idb,sc)) -> + conjunct_bindings (check_mcode sc1 sc) + (conjunct_bindings (match_typeC tya tyb) (match_typeC ida idb)) + | (Ast0.DisjDecl(_,declsa,_,_),Ast0.DisjDecl(_,declsb,_,_)) -> + failwith "not allowed in the pattern of an isomorphism" + | (Ast0.Ddots(d1,None),Ast0.Ddots(d,None)) -> check_mcode d1 d + | (Ast0.Ddots(dd,None),Ast0.Ddots(d,Some wc)) -> + conjunct_bindings (check_mcode dd d) + (* hope that mcode of ddots is unique somehow *) + (let (ddots_whencode_allowed,_,_) = whencode_allowed in + if ddots_whencode_allowed + then add_dot_binding dd (Ast0.DeclTag wc) + else + (Printf.printf "warning: not applying iso because of whencode"; + return false)) + | (Ast0.Ddots(_,Some _),_) -> + failwith "whencode not allowed in a pattern1" + + | (Ast0.OptDecl(decla),Ast0.OptDecl(declb)) + | (Ast0.UniqueDecl(decla),Ast0.UniqueDecl(declb)) -> + match_decl decla declb + | (_,Ast0.OptDecl(declb)) + | (_,Ast0.UniqueDecl(declb)) -> + match_decl pattern declb + | _ -> return false + else return_false (ContextRequired (Ast0.DeclTag d)) + + and match_init pattern i = + if not(checks_needed) or not(context_required) or is_context i + then + match (Ast0.unwrap pattern,Ast0.unwrap i) with + (Ast0.InitExpr(expa),Ast0.InitExpr(expb)) -> + match_expr expa expb + | (Ast0.InitList(lb1,initlista,rb1),Ast0.InitList(lb,initlistb,rb)) -> + conjunct_many_bindings + [check_mcode lb1 lb; check_mcode rb1 rb; + match_dots match_init no_list do_nolist_match + initlista initlistb] + | (Ast0.InitGccDotName(d1,namea,e1,inia), + Ast0.InitGccDotName(d,nameb,e,inib)) -> + conjunct_many_bindings + [check_mcode d1 d; check_mcode e1 e; + match_ident namea nameb; match_init inia inib] + | (Ast0.InitGccName(namea,c1,inia),Ast0.InitGccName(nameb,c,inib)) -> + conjunct_many_bindings + [check_mcode c1 c; match_ident namea nameb; + match_init inia inib] + | (Ast0.InitGccIndex(lb1,expa,rb1,e1,inia), + Ast0.InitGccIndex(lb2,expb,rb2,e2,inib)) -> + conjunct_many_bindings + [check_mcode lb1 lb2; check_mcode rb1 rb2; check_mcode e1 e2; + match_expr expa expb; match_init inia inib] + | (Ast0.InitGccRange(lb1,exp1a,d1,exp2a,rb1,e1,inia), + Ast0.InitGccRange(lb2,exp1b,d2,exp2b,rb2,e2,inib)) -> + conjunct_many_bindings + [check_mcode lb1 lb2; check_mcode d1 d2; + check_mcode rb1 rb2; check_mcode e1 e2; + match_expr exp1a exp1b; match_expr exp2a exp2b; + match_init inia inib] + | (Ast0.IComma(c1),Ast0.IComma(c)) -> check_mcode c1 c + | (Ast0.Idots(d1,None),Ast0.Idots(d,None)) -> check_mcode d1 d + | (Ast0.Idots(id,None),Ast0.Idots(d,Some wc)) -> + conjunct_bindings (check_mcode id d) + (* hope that mcode of edots is unique somehow *) + (let (_,idots_whencode_allowed,_) = whencode_allowed in + if idots_whencode_allowed + then add_dot_binding id (Ast0.InitTag wc) + else + (Printf.printf "warning: not applying iso because of whencode"; + return false)) + | (Ast0.Idots(_,Some _),_) -> + failwith "whencode not allowed in a pattern2" + | (Ast0.OptIni(ia),Ast0.OptIni(ib)) + | (Ast0.UniqueIni(ia),Ast0.UniqueIni(ib)) -> match_init ia ib + | (_,Ast0.OptIni(ib)) + | (_,Ast0.UniqueIni(ib)) -> match_init pattern ib + | _ -> return false + else return_false (ContextRequired (Ast0.InitTag i)) + + and match_param pattern p = + match Ast0.unwrap pattern with + Ast0.MetaParam(name,pure) -> + add_pure_binding name pure pure_sp_code.V0.combiner_parameter + (function p -> Ast0.ParamTag p) + p + | Ast0.MetaParamList(name,_,pure) -> failwith "metaparamlist not supported" + | up -> + if not(checks_needed) or not(context_required) or is_context p + then + match (up,Ast0.unwrap p) with + (Ast0.VoidParam(tya),Ast0.VoidParam(tyb)) -> match_typeC tya tyb + | (Ast0.Param(tya,ida),Ast0.Param(tyb,idb)) -> + conjunct_bindings (match_typeC tya tyb) + (match_option match_ident ida idb) + | (Ast0.PComma(c1),Ast0.PComma(c)) -> check_mcode c1 c + | (Ast0.Pdots(d1),Ast0.Pdots(d)) + | (Ast0.Pcircles(d1),Ast0.Pcircles(d)) -> check_mcode d1 d + | (Ast0.OptParam(parama),Ast0.OptParam(paramb)) + | (Ast0.UniqueParam(parama),Ast0.UniqueParam(paramb)) -> + match_param parama paramb + | (_,Ast0.OptParam(paramb)) + | (_,Ast0.UniqueParam(paramb)) -> match_param pattern paramb + | _ -> return false + else return_false (ContextRequired (Ast0.ParamTag p)) + + and match_statement pattern s = + match Ast0.unwrap pattern with + Ast0.MetaStmt(name,pure) -> + (match Ast0.unwrap s with + Ast0.Dots(_,_) | Ast0.Circles(_,_) | Ast0.Stars(_,_) -> + return false (* ... is not a single statement *) + | _ -> + add_pure_binding name pure pure_sp_code.V0.combiner_statement + (function ty -> Ast0.StmtTag ty) + s) + | Ast0.MetaStmtList(name,pure) -> failwith "metastmtlist not supported" + | up -> + if not(checks_needed) or not(context_required) or is_context s + then + match (up,Ast0.unwrap s) with + (Ast0.FunDecl(_,fninfoa,namea,lp1,paramsa,rp1,lb1,bodya,rb1), + Ast0.FunDecl(_,fninfob,nameb,lp,paramsb,rp,lb,bodyb,rb)) -> + conjunct_many_bindings + [check_mcode lp1 lp; check_mcode rp1 rp; + check_mcode lb1 lb; check_mcode rb1 rb; + match_fninfo fninfoa fninfob; match_ident namea nameb; + match_dots match_param is_plist_matcher do_plist_match + paramsa paramsb; + match_dots match_statement is_slist_matcher do_slist_match + bodya bodyb] + | (Ast0.Decl(_,decla),Ast0.Decl(_,declb)) -> + match_decl decla declb + | (Ast0.Seq(lb1,bodya,rb1),Ast0.Seq(lb,bodyb,rb)) -> + (* seqs can only match if they are all minus (plus code + allowed) or all context (plus code not allowed in the body). + we could be more permissive if the expansions of the isos are + also all seqs, but this would be hard to check except at top + level, and perhaps not worth checking even in that case. + Overall, the issue is that braces are used where single + statements are required, and something not satisfying these + conditions can cause a single statement to become a + non-single statement after the transformation. + + example: if { ... -foo(); ... } + if we let the sequence convert to just -foo(); + then we produce invalid code. For some reason, + single_statement can't deal with this case, perhaps because + it starts introducing too many braces? don't remember the + exact problem... + *) + conjunct_bindings (check_mcode lb1 lb) + (conjunct_bindings (check_mcode rb1 rb) + (if not(checks_needed) or is_minus s or + (is_context s && + List.for_all is_pure_context (Ast0.undots bodyb)) + then + match_dots match_statement is_slist_matcher do_slist_match + bodya bodyb + else return_false (Braces(s)))) + | (Ast0.ExprStatement(expa,sc1),Ast0.ExprStatement(expb,sc)) -> + conjunct_bindings (check_mcode sc1 sc) (match_expr expa expb) + | (Ast0.IfThen(if1,lp1,expa,rp1,branch1a,_), + Ast0.IfThen(if2,lp2,expb,rp2,branch1b,_)) -> + conjunct_many_bindings + [check_mcode if1 if2; check_mcode lp1 lp2; + check_mcode rp1 rp2; + match_expr expa expb; + match_statement branch1a branch1b] + | (Ast0.IfThenElse(if1,lp1,expa,rp1,branch1a,e1,branch2a,_), + Ast0.IfThenElse(if2,lp2,expb,rp2,branch1b,e2,branch2b,_)) -> + conjunct_many_bindings + [check_mcode if1 if2; check_mcode lp1 lp2; + check_mcode rp1 rp2; check_mcode e1 e2; + match_expr expa expb; + match_statement branch1a branch1b; + match_statement branch2a branch2b] + | (Ast0.While(w1,lp1,expa,rp1,bodya,_), + Ast0.While(w,lp,expb,rp,bodyb,_)) -> + conjunct_many_bindings + [check_mcode w1 w; check_mcode lp1 lp; + check_mcode rp1 rp; match_expr expa expb; + match_statement bodya bodyb] + | (Ast0.Do(d1,bodya,w1,lp1,expa,rp1,_), + Ast0.Do(d,bodyb,w,lp,expb,rp,_)) -> + conjunct_many_bindings + [check_mcode d1 d; check_mcode w1 w; check_mcode lp1 lp; + check_mcode rp1 rp; match_statement bodya bodyb; + match_expr expa expb] + | (Ast0.For(f1,lp1,e1a,sc1a,e2a,sc2a,e3a,rp1,bodya,_), + Ast0.For(f,lp,e1b,sc1b,e2b,sc2b,e3b,rp,bodyb,_)) -> + conjunct_many_bindings + [check_mcode f1 f; check_mcode lp1 lp; check_mcode sc1a sc1b; + check_mcode sc2a sc2b; check_mcode rp1 rp; + match_option match_expr e1a e1b; + match_option match_expr e2a e2b; + match_option match_expr e3a e3b; + match_statement bodya bodyb] + | (Ast0.Iterator(nma,lp1,argsa,rp1,bodya,_), + Ast0.Iterator(nmb,lp,argsb,rp,bodyb,_)) -> + conjunct_many_bindings + [match_ident nma nmb; + check_mcode lp1 lp; check_mcode rp1 rp; + match_dots match_expr is_elist_matcher do_elist_match + argsa argsb; + match_statement bodya bodyb] + | (Ast0.Switch(s1,lp1,expa,rp1,lb1,casesa,rb1), + Ast0.Switch(s,lp,expb,rp,lb,casesb,rb)) -> + conjunct_many_bindings + [check_mcode s1 s; check_mcode lp1 lp; check_mcode rp1 rp; + check_mcode lb1 lb; check_mcode rb1 rb; + match_expr expa expb; + match_dots match_case_line no_list do_nolist_match + casesa casesb] + | (Ast0.Break(b1,sc1),Ast0.Break(b,sc)) + | (Ast0.Continue(b1,sc1),Ast0.Continue(b,sc)) -> + conjunct_bindings (check_mcode b1 b) (check_mcode sc1 sc) + | (Ast0.Label(l1,c1),Ast0.Label(l2,c)) -> + conjunct_bindings (match_ident l1 l2) (check_mcode c1 c) + | (Ast0.Goto(g1,l1,sc1),Ast0.Goto(g,l2,sc)) -> + conjunct_many_bindings + [check_mcode g1 g; check_mcode sc1 sc; match_ident l1 l2] + | (Ast0.Return(r1,sc1),Ast0.Return(r,sc)) -> + conjunct_bindings (check_mcode r1 r) (check_mcode sc1 sc) + | (Ast0.ReturnExpr(r1,expa,sc1),Ast0.ReturnExpr(r,expb,sc)) -> + conjunct_many_bindings + [check_mcode r1 r; check_mcode sc1 sc; match_expr expa expb] + | (Ast0.Disj(_,statement_dots_lista,_,_),_) -> + failwith "disj not supported in patterns" + | (Ast0.Nest(_,stmt_dotsa,_,_,_),_) -> + failwith "nest not supported in patterns" + | (Ast0.Exp(expa),Ast0.Exp(expb)) -> match_expr expa expb + | (Ast0.TopExp(expa),Ast0.TopExp(expb)) -> match_expr expa expb + | (Ast0.Exp(expa),Ast0.TopExp(expb)) -> match_expr expa expb + | (Ast0.TopInit(inita),Ast0.TopInit(initb)) -> match_init inita initb + | (Ast0.Ty(tya),Ast0.Ty(tyb)) -> match_typeC tya tyb + | (Ast0.Dots(d,[]),Ast0.Dots(d1,wc)) + | (Ast0.Circles(d,[]),Ast0.Circles(d1,wc)) + | (Ast0.Stars(d,[]),Ast0.Stars(d1,wc)) -> + (match wc with + [] -> check_mcode d d1 + | _ -> + let (_,_,dots_whencode_allowed) = whencode_allowed in + if dots_whencode_allowed + then + conjunct_bindings (check_mcode d d1) + (List.fold_left + (function prev -> + function + | Ast0.WhenNot wc -> + conjunct_bindings prev + (add_multi_dot_binding d + (Ast0.DotsStmtTag wc)) + | Ast0.WhenAlways wc -> + conjunct_bindings prev + (add_multi_dot_binding d (Ast0.StmtTag wc)) + | Ast0.WhenNotTrue wc -> + conjunct_bindings prev + (add_multi_dot_binding d + (Ast0.IsoWhenTTag wc)) + | Ast0.WhenNotFalse wc -> + conjunct_bindings prev + (add_multi_dot_binding d + (Ast0.IsoWhenFTag wc)) + | Ast0.WhenModifier(x) -> + conjunct_bindings prev + (add_multi_dot_binding d + (Ast0.IsoWhenTag x))) + (return true) wc) + else + (Printf.printf + "warning: not applying iso because of whencode"; + return false)) + | (Ast0.Dots(_,_::_),_) | (Ast0.Circles(_,_::_),_) + | (Ast0.Stars(_,_::_),_) -> + failwith "whencode not allowed in a pattern3" + | (Ast0.OptStm(rea),Ast0.OptStm(reb)) + | (Ast0.UniqueStm(rea),Ast0.UniqueStm(reb)) -> + match_statement rea reb + | (_,Ast0.OptStm(reb)) + | (_,Ast0.UniqueStm(reb)) -> match_statement pattern reb + | _ -> return false + else return_false (ContextRequired (Ast0.StmtTag s)) + + (* first should provide a subset of the information in the second *) + and match_fninfo patterninfo cinfo = + let patterninfo = List.sort compare patterninfo in + let cinfo = List.sort compare cinfo in + let rec loop = function + (Ast0.FStorage(sta)::resta,Ast0.FStorage(stb)::restb) -> + if mcode_equal sta stb + then conjunct_bindings (check_mcode sta stb) (loop (resta,restb)) + else return false + | (Ast0.FType(tya)::resta,Ast0.FType(tyb)::restb) -> + conjunct_bindings (match_typeC tya tyb) (loop (resta,restb)) + | (Ast0.FInline(ia)::resta,Ast0.FInline(ib)::restb) -> + if mcode_equal ia ib + then conjunct_bindings (check_mcode ia ib) (loop (resta,restb)) + else return false + | (Ast0.FAttr(ia)::resta,Ast0.FAttr(ib)::restb) -> + if mcode_equal ia ib + then conjunct_bindings (check_mcode ia ib) (loop (resta,restb)) + else return false + | (x::resta,((y::_) as restb)) -> + (match compare x y with + -1 -> return false + | 1 -> loop (resta,restb) + | _ -> failwith "not possible") + | _ -> return false in + loop (patterninfo,cinfo) + + and match_case_line pattern c = + if not(checks_needed) or not(context_required) or is_context c + then + match (Ast0.unwrap pattern,Ast0.unwrap c) with + (Ast0.Default(d1,c1,codea),Ast0.Default(d,c,codeb)) -> + conjunct_many_bindings + [check_mcode d1 d; check_mcode c1 c; + match_dots match_statement is_slist_matcher do_slist_match + codea codeb] + | (Ast0.Case(ca1,expa,c1,codea),Ast0.Case(ca,expb,c,codeb)) -> + conjunct_many_bindings + [check_mcode ca1 ca; check_mcode c1 c; match_expr expa expb; + match_dots match_statement is_slist_matcher do_slist_match + codea codeb] + | (Ast0.OptCase(ca),Ast0.OptCase(cb)) -> match_case_line ca cb + | (_,Ast0.OptCase(cb)) -> match_case_line pattern cb + | _ -> return false + else return_false (ContextRequired (Ast0.CaseLineTag c)) in + + let match_statement_dots x y = + match_dots match_statement is_slist_matcher do_slist_match x y in + + (match_expr, match_decl, match_statement, match_typeC, + match_statement_dots) + +let match_expr dochecks context_required whencode_allowed = + let (fn,_,_,_,_) = match_maker dochecks context_required whencode_allowed in + fn + +let match_decl dochecks context_required whencode_allowed = + let (_,fn,_,_,_) = match_maker dochecks context_required whencode_allowed in + fn + +let match_statement dochecks context_required whencode_allowed = + let (_,_,fn,_,_) = match_maker dochecks context_required whencode_allowed in + fn + +let match_typeC dochecks context_required whencode_allowed = + let (_,_,_,fn,_) = match_maker dochecks context_required whencode_allowed in + fn + +let match_statement_dots dochecks context_required whencode_allowed = + let (_,_,_,_,fn) = match_maker dochecks context_required whencode_allowed in + fn + +(* --------------------------------------------------------------------- *) +(* make an entire tree MINUS *) + +let make_minus = + let mcode (term,arity,info,mcodekind,pos) = + let new_mcodekind = + match mcodekind with + Ast0.CONTEXT(mc) -> + (match !mc with + (Ast.NOTHING,_,_) -> Ast0.MINUS(ref([],Ast0.default_token_info)) + | _ -> failwith "make_minus: unexpected befaft") + | Ast0.MINUS(mc) -> mcodekind (* in the part copied from the src term *) + | _ -> failwith "make_minus mcode: unexpected mcodekind" in + (term,arity,info,new_mcodekind,pos) in + + let update_mc mcodekind e = + match !mcodekind with + Ast0.CONTEXT(mc) -> + (match !mc with + (Ast.NOTHING,_,_) -> + mcodekind := Ast0.MINUS(ref([],Ast0.default_token_info)) + | _ -> failwith "make_minus: unexpected befaft") + | Ast0.MINUS(_mc) -> () (* in the part copied from the src term *) + | Ast0.PLUS -> failwith "make_minus donothing: unexpected plus mcodekind" + | _ -> failwith "make_minus donothing: unexpected mcodekind" in + + let donothing r k e = + let mcodekind = Ast0.get_mcodekind_ref e in + let e = k e in update_mc mcodekind e; e in + + (* special case for whencode, because it isn't processed by contextneg, + since it doesn't appear in the + code *) + (* cases for dots and nests *) + let expression r k e = + let mcodekind = Ast0.get_mcodekind_ref e in + match Ast0.unwrap e with + Ast0.Edots(d,whencode) -> + (*don't recurse because whencode hasn't been processed by context_neg*) + update_mc mcodekind e; Ast0.rewrap e (Ast0.Edots(mcode d,whencode)) + | Ast0.Ecircles(d,whencode) -> + (*don't recurse because whencode hasn't been processed by context_neg*) + update_mc mcodekind e; Ast0.rewrap e (Ast0.Ecircles(mcode d,whencode)) + | Ast0.Estars(d,whencode) -> + (*don't recurse because whencode hasn't been processed by context_neg*) + update_mc mcodekind e; Ast0.rewrap e (Ast0.Estars(mcode d,whencode)) + | Ast0.NestExpr(starter,expr_dots,ender,whencode,multi) -> + update_mc mcodekind e; + Ast0.rewrap e + (Ast0.NestExpr(mcode starter, + r.V0.rebuilder_expression_dots expr_dots, + mcode ender,whencode,multi)) + | _ -> donothing r k e in + + let declaration r k e = + let mcodekind = Ast0.get_mcodekind_ref e in + match Ast0.unwrap e with + Ast0.Ddots(d,whencode) -> + (*don't recurse because whencode hasn't been processed by context_neg*) + update_mc mcodekind e; Ast0.rewrap e (Ast0.Ddots(mcode d,whencode)) + | _ -> donothing r k e in + + let statement r k e = + let mcodekind = Ast0.get_mcodekind_ref e in + match Ast0.unwrap e with + Ast0.Dots(d,whencode) -> + (*don't recurse because whencode hasn't been processed by context_neg*) + update_mc mcodekind e; Ast0.rewrap e (Ast0.Dots(mcode d,whencode)) + | Ast0.Circles(d,whencode) -> + update_mc mcodekind e; Ast0.rewrap e (Ast0.Circles(mcode d,whencode)) + | Ast0.Stars(d,whencode) -> + update_mc mcodekind e; Ast0.rewrap e (Ast0.Stars(mcode d,whencode)) + | Ast0.Nest(starter,stmt_dots,ender,whencode,multi) -> + update_mc mcodekind e; + Ast0.rewrap e + (Ast0.Nest(mcode starter,r.V0.rebuilder_statement_dots stmt_dots, + mcode ender,whencode,multi)) + | _ -> donothing r k e in + + let initialiser r k e = + let mcodekind = Ast0.get_mcodekind_ref e in + match Ast0.unwrap e with + Ast0.Idots(d,whencode) -> + (*don't recurse because whencode hasn't been processed by context_neg*) + update_mc mcodekind e; Ast0.rewrap e (Ast0.Idots(mcode d,whencode)) + | _ -> donothing r k e in + + let dots r k e = + let info = Ast0.get_info e in + let mcodekind = Ast0.get_mcodekind_ref e in + match Ast0.unwrap e with + Ast0.DOTS([]) -> + (* if context is - this should be - as well. There are no tokens + here though, so the bottom-up minusifier in context_neg leaves it + as mixed (or context for sgrep2). It would be better to fix + context_neg, but that would + require a special case for each term with a dots subterm. *) + (match !mcodekind with + Ast0.MIXED(mc) | Ast0.CONTEXT(mc) -> + (match !mc with + (Ast.NOTHING,_,_) -> + mcodekind := Ast0.MINUS(ref([],Ast0.default_token_info)); + e + | _ -> failwith "make_minus: unexpected befaft") + (* code already processed by an enclosing iso *) + | Ast0.MINUS(mc) -> e + | _ -> + failwith + (Printf.sprintf + "%d: make_minus donothingxxx: unexpected mcodekind: %s" + info.Ast0.line_start (Dumper.dump e))) + | _ -> donothing r k e in + + V0.rebuilder + mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode + mcode + dots dots dots dots dots dots + donothing expression donothing initialiser donothing declaration + statement donothing donothing + +(* --------------------------------------------------------------------- *) +(* rebuild mcode cells in an instantiated alt *) + +(* mcodes will be side effected later with plus code, so we have to copy + them on instantiating an isomorphism. One could wonder whether it would + be better not to use side-effects, but they are convenient for insert_plus + where is it useful to manipulate a list of the mcodes but side-effect a + tree *) +(* hmm... Insert_plus is called before Iso_pattern... *) +let rebuild_mcode start_line = + let copy_mcodekind = function + Ast0.CONTEXT(mc) -> Ast0.CONTEXT(ref (!mc)) + | Ast0.MINUS(mc) -> Ast0.MINUS(ref (!mc)) + | Ast0.MIXED(mc) -> Ast0.MIXED(ref (!mc)) + | Ast0.PLUS -> + (* this function is used elsewhere where we need to rebuild the + indices, and so we allow PLUS code as well *) + Ast0.PLUS in + + let mcode (term,arity,info,mcodekind,pos) = + let info = + match start_line with + Some x -> {info with Ast0.line_start = x; Ast0.line_end = x} + | None -> info in + (term,arity,info,copy_mcodekind mcodekind,pos) in + + let copy_one x = + let old_info = Ast0.get_info x in + let info = + match start_line with + Some x -> {old_info with Ast0.line_start = x; Ast0.line_end = x} + | None -> old_info in + {x with Ast0.info = info; Ast0.index = ref(Ast0.get_index x); + Ast0.mcodekind = ref (copy_mcodekind (Ast0.get_mcodekind x))} in + + let donothing r k e = copy_one (k e) in + + (* case for control operators (if, etc) *) + let statement r k e = + let s = k e in + let res = + copy_one + (Ast0.rewrap s + (match Ast0.unwrap s with + Ast0.Decl((info,mc),decl) -> + Ast0.Decl((info,copy_mcodekind mc),decl) + | Ast0.IfThen(iff,lp,tst,rp,branch,(info,mc)) -> + Ast0.IfThen(iff,lp,tst,rp,branch,(info,copy_mcodekind mc)) + | Ast0.IfThenElse(iff,lp,tst,rp,branch1,els,branch2,(info,mc)) -> + Ast0.IfThenElse(iff,lp,tst,rp,branch1,els,branch2, + (info,copy_mcodekind mc)) + | Ast0.While(whl,lp,exp,rp,body,(info,mc)) -> + Ast0.While(whl,lp,exp,rp,body,(info,copy_mcodekind mc)) + | Ast0.For(fr,lp,e1,sem1,e2,sem2,e3,rp,body,(info,mc)) -> + Ast0.For(fr,lp,e1,sem1,e2,sem2,e3,rp,body, + (info,copy_mcodekind mc)) + | Ast0.Iterator(nm,lp,args,rp,body,(info,mc)) -> + Ast0.Iterator(nm,lp,args,rp,body,(info,copy_mcodekind mc)) + | Ast0.FunDecl + ((info,mc),fninfo,name,lp,params,rp,lbrace,body,rbrace) -> + Ast0.FunDecl + ((info,copy_mcodekind mc), + fninfo,name,lp,params,rp,lbrace,body,rbrace) + | s -> s)) in + Ast0.set_dots_bef_aft res + (match Ast0.get_dots_bef_aft res with + Ast0.NoDots -> Ast0.NoDots + | Ast0.AddingBetweenDots s -> + Ast0.AddingBetweenDots(r.V0.rebuilder_statement s) + | Ast0.DroppingBetweenDots s -> + Ast0.DroppingBetweenDots(r.V0.rebuilder_statement s)) in + + V0.rebuilder + mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode + mcode + donothing donothing donothing donothing donothing donothing + donothing donothing donothing donothing donothing + donothing statement donothing donothing + +(* --------------------------------------------------------------------- *) +(* The problem of whencode. If an isomorphism contains dots in multiple + rules, then the code that is matched cannot contain whencode, because we + won't know which dots it goes with. Should worry about nests, but they + aren't allowed in isomorphisms for the moment. *) + +let count_edots = + let mcode x = 0 in + let option_default = 0 in + let bind x y = x + y in + let donothing r k e = k e in + let exprfn r k e = + match Ast0.unwrap e with + Ast0.Edots(_,_) | Ast0.Ecircles(_,_) | Ast0.Estars(_,_) -> 1 + | _ -> 0 in + + V0.combiner bind option_default + mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode + mcode + donothing donothing donothing donothing donothing donothing + donothing exprfn donothing donothing donothing donothing donothing + donothing donothing + +let count_idots = + let mcode x = 0 in + let option_default = 0 in + let bind x y = x + y in + let donothing r k e = k e in + let initfn r k e = + match Ast0.unwrap e with Ast0.Idots(_,_) -> 1 | _ -> 0 in + + V0.combiner bind option_default + mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode + mcode + donothing donothing donothing donothing donothing donothing + donothing donothing donothing initfn donothing donothing donothing + donothing donothing + +let count_dots = + let mcode x = 0 in + let option_default = 0 in + let bind x y = x + y in + let donothing r k e = k e in + let stmtfn r k e = + match Ast0.unwrap e with + Ast0.Dots(_,_) | Ast0.Circles(_,_) | Ast0.Stars(_,_) -> 1 + | _ -> 0 in + + V0.combiner bind option_default + mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode + mcode + donothing donothing donothing donothing donothing donothing + donothing donothing donothing donothing donothing donothing stmtfn + donothing donothing + +(* --------------------------------------------------------------------- *) + +let lookup name bindings mv_bindings = + try Common.Left (List.assoc (term name) bindings) + with + Not_found -> + (* failure is not possible anymore *) + Common.Right (List.assoc (term name) mv_bindings) + +(* mv_bindings is for the fresh metavariables that are introduced by the +isomorphism *) +let instantiate bindings mv_bindings = + let mcode x = + match Ast0.get_pos x with + Ast0.MetaPos(name,_,_) -> + (try + match lookup name bindings mv_bindings with + Common.Left(Ast0.MetaPosTag(id)) -> Ast0.set_pos id x + | _ -> failwith "not possible" + with Not_found -> Ast0.set_pos Ast0.NoMetaPos x) + | _ -> x in + let donothing r k e = k e in + + (* cases where metavariables can occur *) + let identfn r k e = + let e = k e in + match Ast0.unwrap e with + Ast0.MetaId(name,constraints,pure) -> + (rebuild_mcode None).V0.rebuilder_ident + (match lookup name bindings mv_bindings with + Common.Left(Ast0.IdentTag(id)) -> id + | Common.Left(_) -> failwith "not possible 1" + | Common.Right(new_mv) -> + Ast0.rewrap e + (Ast0.MetaId + (Ast0.set_mcode_data new_mv name,constraints,pure))) + | Ast0.MetaFunc(name,_,pure) -> failwith "metafunc not supported" + | Ast0.MetaLocalFunc(name,_,pure) -> failwith "metalocalfunc not supported" + | _ -> e in + + (* case for list metavariables *) + let rec elist r same_dots = function + [] -> [] + | [x] -> + (match Ast0.unwrap x with + Ast0.MetaExprList(name,lenname,pure) -> + failwith "meta_expr_list in iso not supported" + (*match lookup name bindings mv_bindings with + Common.Left(Ast0.DotsExprTag(exp)) -> + (match same_dots exp with + Some l -> l + | None -> failwith "dots put in incompatible context") + | Common.Left(Ast0.ExprTag(exp)) -> [exp] + | Common.Left(_) -> failwith "not possible 1" + | Common.Right(new_mv) -> + failwith "MetaExprList in SP not supported"*) + | _ -> [r.V0.rebuilder_expression x]) + | x::xs -> (r.V0.rebuilder_expression x)::(elist r same_dots xs) in + + let rec plist r same_dots = function + [] -> [] + | [x] -> + (match Ast0.unwrap x with + Ast0.MetaParamList(name,lenname,pure) -> + failwith "meta_param_list in iso not supported" + (*match lookup name bindings mv_bindings with + Common.Left(Ast0.DotsParamTag(param)) -> + (match same_dots param with + Some l -> l + | None -> failwith "dots put in incompatible context") + | Common.Left(Ast0.ParamTag(param)) -> [param] + | Common.Left(_) -> failwith "not possible 1" + | Common.Right(new_mv) -> + failwith "MetaExprList in SP not supported"*) + | _ -> [r.V0.rebuilder_parameter x]) + | x::xs -> (r.V0.rebuilder_parameter x)::(plist r same_dots xs) in + + let rec slist r same_dots = function + [] -> [] + | [x] -> + (match Ast0.unwrap x with + Ast0.MetaStmtList(name,pure) -> + (match lookup name bindings mv_bindings with + Common.Left(Ast0.DotsStmtTag(stm)) -> + (match same_dots stm with + Some l -> l + | None -> failwith "dots put in incompatible context") + | Common.Left(Ast0.StmtTag(stm)) -> [stm] + | Common.Left(_) -> failwith "not possible 1" + | Common.Right(new_mv) -> + failwith "MetaExprList in SP not supported") + | _ -> [r.V0.rebuilder_statement x]) + | x::xs -> (r.V0.rebuilder_statement x)::(slist r same_dots xs) in + + let same_dots d = + match Ast0.unwrap d with Ast0.DOTS(l) -> Some l |_ -> None in + let same_circles d = + match Ast0.unwrap d with Ast0.CIRCLES(l) -> Some l |_ -> None in + let same_stars d = + match Ast0.unwrap d with Ast0.STARS(l) -> Some l |_ -> None in + + let dots list_fn r k d = + Ast0.rewrap d + (match Ast0.unwrap d with + Ast0.DOTS(l) -> Ast0.DOTS(list_fn r same_dots l) + | Ast0.CIRCLES(l) -> Ast0.CIRCLES(list_fn r same_circles l) + | Ast0.STARS(l) -> Ast0.STARS(list_fn r same_stars l)) in + + let exprfn r k old_e = (* need to keep the original code for ! optim *) + let e = k old_e in + let e1 = + match Ast0.unwrap e with + Ast0.MetaExpr(name,constraints,x,form,pure) -> + (rebuild_mcode None).V0.rebuilder_expression + (match lookup name bindings mv_bindings with + Common.Left(Ast0.ExprTag(exp)) -> exp + | Common.Left(_) -> failwith "not possible 1" + | Common.Right(new_mv) -> + let new_types = + match x with + None -> None + | Some types -> + let rec renamer = function + Type_cocci.MetaType(name,keep,inherited) -> + (match + lookup (name,(),(),(),None) bindings mv_bindings + with + Common.Left(Ast0.TypeCTag(t)) -> + Ast0.ast0_type_to_type t + | Common.Left(_) -> + failwith "iso pattern: unexpected type" + | Common.Right(new_mv) -> + Type_cocci.MetaType(new_mv,keep,inherited)) + | Type_cocci.ConstVol(cv,ty) -> + Type_cocci.ConstVol(cv,renamer ty) + | Type_cocci.Pointer(ty) -> + Type_cocci.Pointer(renamer ty) + | Type_cocci.FunctionPointer(ty) -> + Type_cocci.FunctionPointer(renamer ty) + | Type_cocci.Array(ty) -> + Type_cocci.Array(renamer ty) + | t -> t in + Some(List.map renamer types) in + Ast0.rewrap e + (Ast0.MetaExpr + (Ast0.set_mcode_data new_mv name,constraints, + new_types,form,pure))) + | Ast0.MetaErr(namea,_,pure) -> failwith "metaerr not supported" + | Ast0.MetaExprList(namea,lenname,pure) -> + failwith "metaexprlist not supported" + | Ast0.Unary(exp,unop) -> + (match Ast0.unwrap_mcode unop with + Ast.Not -> + let was_meta = + (* k e doesn't change the outer structure of the term, + only the metavars *) + match Ast0.unwrap old_e with + Ast0.Unary(exp,_) -> + (match Ast0.unwrap exp with + Ast0.MetaExpr(name,constraints,x,form,pure) -> true + | _ -> false) + | _ -> failwith "not possible" in + let nomodif e = + let mc = Ast0.get_mcodekind exp in + match mc with + Ast0.MINUS(x) -> + (match !x with + ([],_) -> true + | _ -> false) + | Ast0.CONTEXT(x) | Ast0.MIXED(x) -> + (match !x with + (Ast.NOTHING,_,_) -> true + | _ -> false) + | _ -> failwith "plus not possible" in + if was_meta && nomodif exp && nomodif e + then + let rec negate e (*for rewrapping*) res (*code to process*) = + match Ast0.unwrap res with + Ast0.Unary(e1,op) when Ast0.unwrap_mcode op = Ast.Not -> + Ast0.rewrap e (Ast0.unwrap e1) + | Ast0.Edots(_,_) -> Ast0.rewrap e (Ast0.unwrap res) + | Ast0.Paren(lp,e,rp) -> + Ast0.rewrap res (Ast0.Paren(lp,negate e e,rp)) + | Ast0.Binary(e1,op,e2) -> + let reb nop = Ast0.rewrap_mcode op (Ast.Logical(nop)) in + let invop = + match Ast0.unwrap_mcode op with + Ast.Logical(Ast.Inf) -> + Ast0.Binary(e1,reb Ast.SupEq,e2) + | Ast.Logical(Ast.Sup) -> + Ast0.Binary(e1,reb Ast.InfEq,e2) + | Ast.Logical(Ast.InfEq) -> + Ast0.Binary(e1,reb Ast.Sup,e2) + | Ast.Logical(Ast.SupEq) -> + Ast0.Binary(e1,reb Ast.Inf,e2) + | Ast.Logical(Ast.Eq) -> + Ast0.Binary(e1,reb Ast.NotEq,e2) + | Ast.Logical(Ast.NotEq) -> + Ast0.Binary(e1,reb Ast.Eq,e2) + | Ast.Logical(Ast.AndLog) -> + Ast0.Binary(negate e1 e1,reb Ast.OrLog, + negate e2 e2) + | Ast.Logical(Ast.OrLog) -> + Ast0.Binary(negate e1 e1,reb Ast.AndLog, + negate e2 e2) + | _ -> Ast0.Unary(res,Ast0.rewrap_mcode op Ast.Not) in + Ast0.rewrap e invop + | Ast0.DisjExpr(lp,exps,mids,rp) -> + (* use res because it is the transformed argument *) + let exps = List.map (function e -> negate e e) exps in + Ast0.rewrap res (Ast0.DisjExpr(lp,exps,mids,rp)) + | _ -> + (*use e, because this might be the toplevel expression*) + Ast0.rewrap e + (Ast0.Unary(res,Ast0.rewrap_mcode unop Ast.Not)) in + negate e exp + else e + | _ -> e) + | Ast0.Edots(d,_) -> + (try + (match List.assoc (dot_term d) bindings with + Ast0.ExprTag(exp) -> Ast0.rewrap e (Ast0.Edots(d,Some exp)) + | _ -> failwith "unexpected binding") + with Not_found -> e) + | Ast0.Ecircles(d,_) -> + (try + (match List.assoc (dot_term d) bindings with + Ast0.ExprTag(exp) -> Ast0.rewrap e (Ast0.Ecircles(d,Some exp)) + | _ -> failwith "unexpected binding") + with Not_found -> e) + | Ast0.Estars(d,_) -> + (try + (match List.assoc (dot_term d) bindings with + Ast0.ExprTag(exp) -> Ast0.rewrap e (Ast0.Estars(d,Some exp)) + | _ -> failwith "unexpected binding") + with Not_found -> e) + | _ -> e in + if Ast0.get_test_exp old_e then Ast0.set_test_exp e1 else e1 in + + let tyfn r k e = + let e = k e in + match Ast0.unwrap e with + Ast0.MetaType(name,pure) -> + (rebuild_mcode None).V0.rebuilder_typeC + (match lookup name bindings mv_bindings with + Common.Left(Ast0.TypeCTag(ty)) -> ty + | Common.Left(_) -> failwith "not possible 1" + | Common.Right(new_mv) -> + Ast0.rewrap e + (Ast0.MetaType(Ast0.set_mcode_data new_mv name,pure))) + | _ -> e in + + let declfn r k e = + let e = k e in + match Ast0.unwrap e with + Ast0.Ddots(d,_) -> + (try + (match List.assoc (dot_term d) bindings with + Ast0.DeclTag(exp) -> Ast0.rewrap e (Ast0.Ddots(d,Some exp)) + | _ -> failwith "unexpected binding") + with Not_found -> e) + | _ -> e in + + let paramfn r k e = + let e = k e in + match Ast0.unwrap e with + Ast0.MetaParam(name,pure) -> + (rebuild_mcode None).V0.rebuilder_parameter + (match lookup name bindings mv_bindings with + Common.Left(Ast0.ParamTag(param)) -> param + | Common.Left(_) -> failwith "not possible 1" + | Common.Right(new_mv) -> + Ast0.rewrap e + (Ast0.MetaParam(Ast0.set_mcode_data new_mv name, pure))) + | Ast0.MetaParamList(name,lenname,pure) -> + failwith "metaparamlist not supported" + | _ -> e in + + let whenfn (_,v) = + match v with + Ast0.DotsStmtTag(stms) -> Ast0.WhenNot stms + | Ast0.StmtTag(stm) -> Ast0.WhenAlways stm + | Ast0.IsoWhenTTag(stm) -> Ast0.WhenNotTrue stm + | Ast0.IsoWhenFTag(stm) -> Ast0.WhenNotFalse stm + | Ast0.IsoWhenTag(x) -> Ast0.WhenModifier(x) + | _ -> failwith "unexpected binding" in + + let stmtfn r k e = + let e = k e in + match Ast0.unwrap e with + Ast0.MetaStmt(name,pure) -> + (rebuild_mcode None).V0.rebuilder_statement + (match lookup name bindings mv_bindings with + Common.Left(Ast0.StmtTag(stm)) -> stm + | Common.Left(_) -> failwith "not possible 1" + | Common.Right(new_mv) -> + Ast0.rewrap e + (Ast0.MetaStmt(Ast0.set_mcode_data new_mv name,pure))) + | Ast0.MetaStmtList(name,pure) -> failwith "metastmtlist not supported" + | Ast0.Dots(d,_) -> + Ast0.rewrap e + (Ast0.Dots + (d, + List.map whenfn + (List.filter (function (x,v) -> x = (dot_term d)) bindings))) + | Ast0.Circles(d,_) -> + Ast0.rewrap e + (Ast0.Circles + (d, + List.map whenfn + (List.filter (function (x,v) -> x = (dot_term d)) bindings))) + | Ast0.Stars(d,_) -> + Ast0.rewrap e + (Ast0.Stars + (d, + List.map whenfn + (List.filter (function (x,v) -> x = (dot_term d)) bindings))) + | _ -> e in + + V0.rebuilder + mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode + mcode + (dots elist) donothing (dots plist) (dots slist) donothing donothing + identfn exprfn tyfn donothing paramfn declfn stmtfn donothing donothing + +(* --------------------------------------------------------------------- *) + +let is_minus e = + match Ast0.get_mcodekind e with Ast0.MINUS(cell) -> true | _ -> false + +let context_required e = not(is_minus e) && not !Flag.sgrep_mode2 + +let disj_fail bindings e = + match bindings with + Some x -> Printf.fprintf stderr "no disj available at this type"; e + | None -> e + +(* isomorphism code is by default CONTEXT *) +let merge_plus model_mcode e_mcode = + match model_mcode with + Ast0.MINUS(mc) -> + (* add the replacement information at the root *) + (match e_mcode with + Ast0.MINUS(emc) -> + emc := + (match (!mc,!emc) with + (([],_),(x,t)) | ((x,_),([],t)) -> (x,t) + | _ -> failwith "how can we combine minuses?") + | _ -> failwith "not possible 6") + | Ast0.CONTEXT(mc) -> + (match e_mcode with + Ast0.CONTEXT(emc) -> + (* keep the logical line info as in the model *) + let (mba,tb,ta) = !mc in + let (eba,_,_) = !emc in + (* merging may be required when a term is replaced by a subterm *) + let merged = + match (mba,eba) with + (x,Ast.NOTHING) | (Ast.NOTHING,x) -> x + | (Ast.BEFORE(b1),Ast.BEFORE(b2)) -> Ast.BEFORE(b1@b2) + | (Ast.BEFORE(b),Ast.AFTER(a)) -> Ast.BEFOREAFTER(b,a) + | (Ast.BEFORE(b1),Ast.BEFOREAFTER(b2,a)) -> + Ast.BEFOREAFTER(b1@b2,a) + | (Ast.AFTER(a),Ast.BEFORE(b)) -> Ast.BEFOREAFTER(b,a) + | (Ast.AFTER(a1),Ast.AFTER(a2)) ->Ast.AFTER(a2@a1) + | (Ast.AFTER(a1),Ast.BEFOREAFTER(b,a2)) -> Ast.BEFOREAFTER(b,a2@a1) + | (Ast.BEFOREAFTER(b1,a),Ast.BEFORE(b2)) -> + Ast.BEFOREAFTER(b1@b2,a) + | (Ast.BEFOREAFTER(b,a1),Ast.AFTER(a2)) -> + Ast.BEFOREAFTER(b,a2@a1) + | (Ast.BEFOREAFTER(b1,a1),Ast.BEFOREAFTER(b2,a2)) -> + Ast.BEFOREAFTER(b1@b2,a2@a1) in + emc := (merged,tb,ta) + | Ast0.MINUS(emc) -> + let (anything_bef_aft,_,_) = !mc in + let (anythings,t) = !emc in + emc := + (match anything_bef_aft with + Ast.BEFORE(b) -> (b@anythings,t) + | Ast.AFTER(a) -> (anythings@a,t) + | Ast.BEFOREAFTER(b,a) -> (b@anythings@a,t) + | Ast.NOTHING -> (anythings,t)) + | _ -> failwith "not possible 7") + | Ast0.MIXED(_) -> failwith "not possible 8" + | Ast0.PLUS -> failwith "not possible 9" + +let copy_plus printer minusify model e = + if !Flag.sgrep_mode2 + then e (* no plus code, can cause a "not possible" error, so just avoid it *) + else + let e = + match Ast0.get_mcodekind model with + Ast0.MINUS(mc) -> minusify e + | Ast0.CONTEXT(mc) -> e + | _ -> failwith "not possible: copy_plus\n" in + merge_plus (Ast0.get_mcodekind model) (Ast0.get_mcodekind e); + e + +let copy_minus printer minusify model e = + match Ast0.get_mcodekind model with + Ast0.MINUS(mc) -> minusify e + | Ast0.CONTEXT(mc) -> e + | Ast0.MIXED(_) -> + if !Flag.sgrep_mode2 + then e + else failwith "not possible 8" + | Ast0.PLUS -> failwith "not possible 9" + +let whencode_allowed prev_ecount prev_icount prev_dcount + ecount icount dcount rest = + (* actually, if ecount or dcount is 0, the flag doesn't matter, because it + won't be tested *) + let other_ecount = (* number of edots *) + List.fold_left (function rest -> function (_,ec,ic,dc) -> ec + rest) + prev_ecount rest in + let other_icount = (* number of dots *) + List.fold_left (function rest -> function (_,ec,ic,dc) -> ic + rest) + prev_icount rest in + let other_dcount = (* number of dots *) + List.fold_left (function rest -> function (_,ec,ic,dc) -> dc + rest) + prev_dcount rest in + (ecount = 0 or other_ecount = 0, icount = 0 or other_icount = 0, + dcount = 0 or other_dcount = 0) + +(* copy the befores and afters to the instantiated code *) +let extra_copy_stmt_plus model e = + (if not !Flag.sgrep_mode2 (* sgrep has no plus code, so nothing to do *) + then + (match Ast0.unwrap model with + Ast0.FunDecl((info,bef),_,_,_,_,_,_,_,_) + | Ast0.Decl((info,bef),_) -> + (match Ast0.unwrap e with + Ast0.FunDecl((info,bef1),_,_,_,_,_,_,_,_) + | Ast0.Decl((info,bef1),_) -> + merge_plus bef bef1 + | _ -> merge_plus bef (Ast0.get_mcodekind e)) + | Ast0.IfThen(_,_,_,_,_,(info,aft)) + | Ast0.IfThenElse(_,_,_,_,_,_,_,(info,aft)) + | Ast0.While(_,_,_,_,_,(info,aft)) + | Ast0.For(_,_,_,_,_,_,_,_,_,(info,aft)) + | Ast0.Iterator(_,_,_,_,_,(info,aft)) -> + (match Ast0.unwrap e with + Ast0.IfThen(_,_,_,_,_,(info,aft1)) + | Ast0.IfThenElse(_,_,_,_,_,_,_,(info,aft1)) + | Ast0.While(_,_,_,_,_,(info,aft1)) + | Ast0.For(_,_,_,_,_,_,_,_,_,(info,aft1)) + | Ast0.Iterator(_,_,_,_,_,(info,aft1)) -> + merge_plus aft aft1 + | _ -> merge_plus aft (Ast0.get_mcodekind e)) + | _ -> ())); + e + +let extra_copy_other_plus model e = e + +(* --------------------------------------------------------------------- *) + +let mv_count = ref 0 +let new_mv (_,s) = + let ct = !mv_count in + mv_count := !mv_count + 1; + "_"^s^"_"^(string_of_int ct) + +let get_name = function + Ast.MetaIdDecl(ar,nm) -> + (nm,function nm -> Ast.MetaIdDecl(ar,nm)) + | Ast.MetaFreshIdDecl(ar,nm) -> + (nm,function nm -> Ast.MetaFreshIdDecl(ar,nm)) + | Ast.MetaTypeDecl(ar,nm) -> + (nm,function nm -> Ast.MetaTypeDecl(ar,nm)) + | Ast.MetaListlenDecl(nm) -> + failwith "should not be rebuilt" + | Ast.MetaParamDecl(ar,nm) -> + (nm,function nm -> Ast.MetaParamDecl(ar,nm)) + | Ast.MetaParamListDecl(ar,nm,nm1) -> + (nm,function nm -> Ast.MetaParamListDecl(ar,nm,nm1)) + | Ast.MetaConstDecl(ar,nm,ty) -> + (nm,function nm -> Ast.MetaConstDecl(ar,nm,ty)) + | Ast.MetaErrDecl(ar,nm) -> + (nm,function nm -> Ast.MetaErrDecl(ar,nm)) + | Ast.MetaExpDecl(ar,nm,ty) -> + (nm,function nm -> Ast.MetaExpDecl(ar,nm,ty)) + | Ast.MetaIdExpDecl(ar,nm,ty) -> + (nm,function nm -> Ast.MetaIdExpDecl(ar,nm,ty)) + | Ast.MetaLocalIdExpDecl(ar,nm,ty) -> + (nm,function nm -> Ast.MetaLocalIdExpDecl(ar,nm,ty)) + | Ast.MetaExpListDecl(ar,nm,nm1) -> + (nm,function nm -> Ast.MetaExpListDecl(ar,nm,nm1)) + | Ast.MetaStmDecl(ar,nm) -> + (nm,function nm -> Ast.MetaStmDecl(ar,nm)) + | Ast.MetaStmListDecl(ar,nm) -> + (nm,function nm -> Ast.MetaStmListDecl(ar,nm)) + | Ast.MetaFuncDecl(ar,nm) -> + (nm,function nm -> Ast.MetaFuncDecl(ar,nm)) + | Ast.MetaLocalFuncDecl(ar,nm) -> + (nm,function nm -> Ast.MetaLocalFuncDecl(ar,nm)) + | Ast.MetaPosDecl(ar,nm) -> + (nm,function nm -> Ast.MetaPosDecl(ar,nm)) + | Ast.MetaDeclarerDecl(ar,nm) -> + (nm,function nm -> Ast.MetaDeclarerDecl(ar,nm)) + | Ast.MetaIteratorDecl(ar,nm) -> + (nm,function nm -> Ast.MetaIteratorDecl(ar,nm)) + +let make_new_metavars metavars bindings = + let new_metavars = + List.filter + (function mv -> + let (s,_) = get_name mv in + try let _ = List.assoc s bindings in false with Not_found -> true) + metavars in + List.split + (List.map + (function mv -> + let (s,rebuild) = get_name mv in + let new_s = (!current_rule,new_mv s) in + (rebuild new_s, (s,new_s))) + new_metavars) + +(* --------------------------------------------------------------------- *) + +let do_nothing x = x + +let mkdisj matcher metavars alts e instantiater mkiso disj_maker minusify + rebuild_mcodes name printer extra_plus update_others = + let call_instantiate bindings mv_bindings alts = + List.concat + (List.map + (function (a,_,_,_) -> + nub + (* no need to create duplicates when the bindings have no effect *) + (List.map + (function bindings -> + Ast0.set_iso + (copy_plus printer minusify e + (extra_plus e + (instantiater bindings mv_bindings + (rebuild_mcodes a)))) + (Common.union_set [(name,mkiso a)] (Ast0.get_iso e))) + bindings)) + alts) in + let rec inner_loop all_alts prev_ecount prev_icount prev_dcount = function + [] -> Common.Left (prev_ecount, prev_icount, prev_dcount) + | ((pattern,ecount,icount,dcount)::rest) -> + let wc = + whencode_allowed prev_ecount prev_icount prev_dcount + ecount dcount icount rest in + (match matcher true (context_required e) wc pattern e init_env with + Fail(reason) -> + if reason = NonMatch || not !Flag_parsing_cocci.show_iso_failures + then () + else + (match matcher false false wc pattern e init_env with + OK _ -> + interpret_reason name (Ast0.get_line e) reason + (function () -> printer e) + | _ -> ()); + inner_loop all_alts (prev_ecount + ecount) (prev_icount + icount) + (prev_dcount + dcount) rest + | OK (bindings : (((string * string) * 'a) list list)) -> + let all_alts = + (* apply update_others to all patterns other than the matched + one. This is used to desigate the others as test + expressions in the TestExpression case *) + (List.map + (function (x,e,i,d) as all -> + if x = pattern + then all + else (update_others x,e,i,d)) + (List.hd all_alts)) :: + (List.map + (List.map (function (x,e,i,d) -> (update_others x,e,i,d))) + (List.tl all_alts)) in + (match List.concat all_alts with + [x] -> Common.Left (prev_ecount, prev_icount, prev_dcount) + | all_alts -> + let (new_metavars,mv_bindings) = + make_new_metavars metavars (nub(List.concat bindings)) in + Common.Right + (new_metavars, + call_instantiate bindings mv_bindings all_alts))) in + let rec outer_loop prev_ecount prev_icount prev_dcount = function + [] | [[_]] (*only one alternative*) -> ([],e) (* nothing matched *) + | (alts::rest) as all_alts -> + match inner_loop all_alts prev_ecount prev_icount prev_dcount alts with + Common.Left(prev_ecount, prev_icount, prev_dcount) -> + outer_loop prev_ecount prev_icount prev_dcount rest + | Common.Right (new_metavars,res) -> + (new_metavars, + copy_minus printer minusify e (disj_maker res)) in + outer_loop 0 0 0 alts + +(* no one should ever look at the information stored in these mcodes *) +let disj_starter lst = + let old_info = Ast0.get_info(List.hd lst) in + let info = + { old_info with + Ast0.line_end = old_info.Ast0.line_start; + Ast0.logical_end = old_info.Ast0.logical_start; + Ast0.attachable_start = false; Ast0.attachable_end = false; + Ast0.mcode_start = []; Ast0.mcode_end = []; + Ast0.strings_before = []; Ast0.strings_after = [] } in + Ast0.make_mcode_info "(" info + +let disj_ender lst = + let old_info = Ast0.get_info(List.hd lst) in + let info = + { old_info with + Ast0.line_start = old_info.Ast0.line_end; + Ast0.logical_start = old_info.Ast0.logical_end; + Ast0.attachable_start = false; Ast0.attachable_end = false; + Ast0.mcode_start = []; Ast0.mcode_end = []; + Ast0.strings_before = []; Ast0.strings_after = [] } in + Ast0.make_mcode_info ")" info + +let disj_mid _ = Ast0.make_mcode "|" + +let make_disj_type tl = + let mids = + match tl with + [] -> failwith "bad disjunction" + | x::xs -> List.map disj_mid xs in + Ast0.context_wrap (Ast0.DisjType(disj_starter tl,tl,mids,disj_ender tl)) +let make_disj_stmt_list tl = + let mids = + match tl with + [] -> failwith "bad disjunction" + | x::xs -> List.map disj_mid xs in + Ast0.context_wrap (Ast0.Disj(disj_starter tl,tl,mids,disj_ender tl)) +let make_disj_expr model el = + let mids = + match el with + [] -> failwith "bad disjunction" + | x::xs -> List.map disj_mid xs in + let update_arg x = + if Ast0.get_arg_exp model then Ast0.set_arg_exp x else x in + let update_test x = + let x = if Ast0.get_test_pos model then Ast0.set_test_pos x else x in + if Ast0.get_test_exp model then Ast0.set_test_exp x else x in + let el = List.map update_arg (List.map update_test el) in + Ast0.context_wrap (Ast0.DisjExpr(disj_starter el,el,mids,disj_ender el)) +let make_disj_decl dl = + let mids = + match dl with + [] -> failwith "bad disjunction" + | x::xs -> List.map disj_mid xs in + Ast0.context_wrap (Ast0.DisjDecl(disj_starter dl,dl,mids,disj_ender dl)) +let make_disj_stmt sl = + let dotify x = Ast0.context_wrap (Ast0.DOTS[x]) in + let mids = + match sl with + [] -> failwith "bad disjunction" + | x::xs -> List.map disj_mid xs in + Ast0.context_wrap + (Ast0.Disj(disj_starter sl,List.map dotify sl,mids,disj_ender sl)) + +let transform_type (metavars,alts,name) e = + match alts with + (Ast0.TypeCTag(_)::_)::_ -> + (* start line is given to any leaves in the iso code *) + let start_line = Some ((Ast0.get_info e).Ast0.line_start) in + let alts = + List.map + (List.map + (function + Ast0.TypeCTag(p) -> + (p,count_edots.V0.combiner_typeC p, + count_idots.V0.combiner_typeC p, + count_dots.V0.combiner_typeC p) + | _ -> failwith "invalid alt")) + alts in + mkdisj match_typeC metavars alts e + (function b -> function mv_b -> + (instantiate b mv_b).V0.rebuilder_typeC) + (function t -> Ast0.TypeCTag t) + make_disj_type make_minus.V0.rebuilder_typeC + (rebuild_mcode start_line).V0.rebuilder_typeC + name Unparse_ast0.typeC extra_copy_other_plus do_nothing + | _ -> ([],e) + + +let transform_expr (metavars,alts,name) e = + let process update_others = + (* start line is given to any leaves in the iso code *) + let start_line = Some ((Ast0.get_info e).Ast0.line_start) in + let alts = + List.map + (List.map + (function + Ast0.ExprTag(p) | Ast0.ArgExprTag(p) | Ast0.TestExprTag(p) -> + (p,count_edots.V0.combiner_expression p, + count_idots.V0.combiner_expression p, + count_dots.V0.combiner_expression p) + | _ -> failwith "invalid alt")) + alts in + mkdisj match_expr metavars alts e + (function b -> function mv_b -> + (instantiate b mv_b).V0.rebuilder_expression) + (function e -> Ast0.ExprTag e) + (make_disj_expr e) + make_minus.V0.rebuilder_expression + (rebuild_mcode start_line).V0.rebuilder_expression + name Unparse_ast0.expression extra_copy_other_plus update_others in + match alts with + (Ast0.ExprTag(_)::_)::_ -> process do_nothing + | (Ast0.ArgExprTag(_)::_)::_ when Ast0.get_arg_exp e -> process do_nothing + | (Ast0.TestExprTag(_)::_)::_ when Ast0.get_test_pos e -> + process Ast0.set_test_exp + | _ -> ([],e) + +let transform_decl (metavars,alts,name) e = + match alts with + (Ast0.DeclTag(_)::_)::_ -> + (* start line is given to any leaves in the iso code *) + let start_line = Some (Ast0.get_info e).Ast0.line_start in + let alts = + List.map + (List.map + (function + Ast0.DeclTag(p) -> + (p,count_edots.V0.combiner_declaration p, + count_idots.V0.combiner_declaration p, + count_dots.V0.combiner_declaration p) + | _ -> failwith "invalid alt")) + alts in + mkdisj match_decl metavars alts e + (function b -> function mv_b -> + (instantiate b mv_b).V0.rebuilder_declaration) + (function d -> Ast0.DeclTag d) + make_disj_decl + make_minus.V0.rebuilder_declaration + (rebuild_mcode start_line).V0.rebuilder_declaration + name Unparse_ast0.declaration extra_copy_other_plus do_nothing + | _ -> ([],e) + +let transform_stmt (metavars,alts,name) e = + match alts with + (Ast0.StmtTag(_)::_)::_ -> + (* start line is given to any leaves in the iso code *) + let start_line = Some (Ast0.get_info e).Ast0.line_start in + let alts = + List.map + (List.map + (function + Ast0.StmtTag(p) -> + (p,count_edots.V0.combiner_statement p, + count_idots.V0.combiner_statement p, + count_dots.V0.combiner_statement p) + | _ -> failwith "invalid alt")) + alts in + mkdisj match_statement metavars alts e + (function b -> function mv_b -> + (instantiate b mv_b).V0.rebuilder_statement) + (function s -> Ast0.StmtTag s) + make_disj_stmt make_minus.V0.rebuilder_statement + (rebuild_mcode start_line).V0.rebuilder_statement + name (Unparse_ast0.statement "") extra_copy_stmt_plus do_nothing + | _ -> ([],e) + +(* sort of a hack, because there is no disj at top level *) +let transform_top (metavars,alts,name) e = + match Ast0.unwrap e with + Ast0.DECL(declstm) -> + (try + let strip alts = + List.map + (List.map + (function + Ast0.DotsStmtTag(d) -> + (match Ast0.unwrap d with + Ast0.DOTS([s]) -> Ast0.StmtTag(s) + | _ -> raise (Failure "")) + | _ -> raise (Failure ""))) + alts in + let (mv,s) = transform_stmt (metavars,strip alts,name) declstm in + (mv,Ast0.rewrap e (Ast0.DECL(s))) + with Failure _ -> ([],e)) + | Ast0.CODE(stmts) -> + let (mv,res) = + match alts with + (Ast0.DotsStmtTag(_)::_)::_ -> + (* start line is given to any leaves in the iso code *) + let start_line = Some ((Ast0.get_info e).Ast0.line_start) in + let alts = + List.map + (List.map + (function + Ast0.DotsStmtTag(p) -> + (p,count_edots.V0.combiner_statement_dots p, + count_idots.V0.combiner_statement_dots p, + count_dots.V0.combiner_statement_dots p) + | _ -> failwith "invalid alt")) + alts in + mkdisj match_statement_dots metavars alts stmts + (function b -> function mv_b -> + (instantiate b mv_b).V0.rebuilder_statement_dots) + (function s -> Ast0.DotsStmtTag s) + (function x -> + Ast0.rewrap e (Ast0.DOTS([make_disj_stmt_list x]))) + (function x -> + make_minus.V0.rebuilder_statement_dots x) + (rebuild_mcode start_line).V0.rebuilder_statement_dots + name Unparse_ast0.statement_dots extra_copy_other_plus do_nothing + | _ -> ([],stmts) in + (mv,Ast0.rewrap e (Ast0.CODE res)) + | _ -> ([],e) + +(* --------------------------------------------------------------------- *) + +let transform (alts : isomorphism) t = + (* the following ugliness is because rebuilder only returns a new term *) + let extra_meta_decls = ref ([] : Ast_cocci.metavar list) in + let mcode x = x in + let donothing r k e = k e in + let exprfn r k e = + let (extra_meta,exp) = transform_expr alts (k e) in + extra_meta_decls := extra_meta @ !extra_meta_decls; + exp in + + let declfn r k e = + let (extra_meta,dec) = transform_decl alts (k e) in + extra_meta_decls := extra_meta @ !extra_meta_decls; + dec in + + let stmtfn r k e = + let (extra_meta,stm) = transform_stmt alts (k e) in + extra_meta_decls := extra_meta @ !extra_meta_decls; + stm in + + let typefn r k e = + let (extra_meta,ty) = transform_type alts (k e) in + extra_meta_decls := extra_meta @ !extra_meta_decls; + ty in + + let topfn r k e = + let (extra_meta,ty) = transform_top alts (k e) in + extra_meta_decls := extra_meta @ !extra_meta_decls; + ty in + + let res = + V0.rebuilder + mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode + mcode + donothing donothing donothing donothing donothing donothing + donothing exprfn typefn donothing donothing declfn stmtfn + donothing topfn in + let res = res.V0.rebuilder_top_level t in + (!extra_meta_decls,res) + +(* --------------------------------------------------------------------- *) + +(* should be done by functorizing the parser to use wrap or context_wrap *) +let rewrap = + let mcode (x,a,i,mc,pos) = (x,a,i,Ast0.context_befaft(),pos) in + let donothing r k e = Ast0.context_wrap(Ast0.unwrap(k e)) in + V0.rebuilder + mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode + mcode + donothing donothing donothing donothing donothing donothing + donothing donothing donothing donothing donothing donothing donothing + donothing donothing + +let rewrap_anything = function + Ast0.DotsExprTag(d) -> + Ast0.DotsExprTag(rewrap.V0.rebuilder_expression_dots d) + | Ast0.DotsInitTag(d) -> + Ast0.DotsInitTag(rewrap.V0.rebuilder_initialiser_list d) + | Ast0.DotsParamTag(d) -> + Ast0.DotsParamTag(rewrap.V0.rebuilder_parameter_list d) + | Ast0.DotsStmtTag(d) -> + Ast0.DotsStmtTag(rewrap.V0.rebuilder_statement_dots d) + | Ast0.DotsDeclTag(d) -> + Ast0.DotsDeclTag(rewrap.V0.rebuilder_declaration_dots d) + | Ast0.DotsCaseTag(d) -> + Ast0.DotsCaseTag(rewrap.V0.rebuilder_case_line_dots d) + | Ast0.IdentTag(d) -> Ast0.IdentTag(rewrap.V0.rebuilder_ident d) + | Ast0.ExprTag(d) -> Ast0.ExprTag(rewrap.V0.rebuilder_expression d) + | Ast0.ArgExprTag(d) -> Ast0.ArgExprTag(rewrap.V0.rebuilder_expression d) + | Ast0.TestExprTag(d) -> Ast0.TestExprTag(rewrap.V0.rebuilder_expression d) + | Ast0.TypeCTag(d) -> Ast0.TypeCTag(rewrap.V0.rebuilder_typeC d) + | Ast0.InitTag(d) -> Ast0.InitTag(rewrap.V0.rebuilder_initialiser d) + | Ast0.ParamTag(d) -> Ast0.ParamTag(rewrap.V0.rebuilder_parameter d) + | Ast0.DeclTag(d) -> Ast0.DeclTag(rewrap.V0.rebuilder_declaration d) + | Ast0.StmtTag(d) -> Ast0.StmtTag(rewrap.V0.rebuilder_statement d) + | Ast0.CaseLineTag(d) -> Ast0.CaseLineTag(rewrap.V0.rebuilder_case_line d) + | Ast0.TopTag(d) -> Ast0.TopTag(rewrap.V0.rebuilder_top_level d) + | Ast0.IsoWhenTag(_) | Ast0.IsoWhenTTag(_) | Ast0.IsoWhenFTag(_) -> + failwith "only for isos within iso phase" + | Ast0.MetaPosTag(p) -> Ast0.MetaPosTag(p) + +(* --------------------------------------------------------------------- *) + +let apply_isos isos rule rule_name = + if isos = [] + then ([],rule) + else + begin + current_rule := rule_name; + let isos = + List.map + (function (metavars,iso,name) -> + (metavars,List.map (List.map rewrap_anything) iso,name)) + isos in + let (extra_meta,rule) = + List.split + (List.map + (function t -> + List.fold_left + (function (extra_meta,t) -> function iso -> + let (new_extra_meta,t) = transform iso t in + (new_extra_meta@extra_meta,t)) + ([],t) isos) + rule) in + (List.concat extra_meta, Compute_lines.compute_lines rule) + end diff --git a/parsing_cocci/.#parse_cocci.ml.1.164 b/parsing_cocci/.#parse_cocci.ml.1.164 new file mode 100644 index 0000000..b661baf --- /dev/null +++ b/parsing_cocci/.#parse_cocci.ml.1.164 @@ -0,0 +1,1566 @@ +(* +* Copyright 2005-2008, Ecole des Mines de Nantes, University of Copenhagen +* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller +* This file is part of Coccinelle. +* +* Coccinelle is free software: you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation, according to version 2 of the License. +* +* Coccinelle is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with Coccinelle. If not, see . +* +* The authors reserve the right to distribute this or future versions of +* Coccinelle under other licenses. +*) + + +(* splits the entire file into minus and plus fragments, and parses each +separately (thus duplicating work for the parsing of the context elements) *) + +module D = Data +module PC = Parser_cocci_menhir +module V0 = Visitor_ast0 +module Ast = Ast_cocci +module Ast0 = Ast0_cocci +let pr = Printf.sprintf +(*let pr2 s = prerr_string s; prerr_string "\n"; flush stderr*) +let pr2 s = Printf.printf "%s\n" s + +(* for isomorphisms. all should be at the front!!! *) +let reserved_names = + ["all";"optional_storage";"optional_qualifier";"value_format";"comm_assoc"] + +(* ----------------------------------------------------------------------- *) +(* Debugging... *) + +let line_type (d,_,_,_,_,_,_,_) = d + +let line_type2c tok = + match line_type tok with + D.MINUS | D.OPTMINUS | D.UNIQUEMINUS -> ":-" + | D.PLUS -> ":+" + | D.CONTEXT | D.UNIQUE | D.OPT -> "" + +let token2c (tok,_) = + match tok with + PC.TIdentifier -> "identifier" + | PC.TType -> "type" + | PC.TParameter -> "parameter" + | PC.TConstant -> "constant" + | PC.TExpression -> "expression" + | PC.TIdExpression -> "idexpression" + | PC.TStatement -> "statement" + | PC.TPosition -> "position" + | PC.TPosAny -> "any" + | PC.TFunction -> "function" + | PC.TLocal -> "local" + | PC.Tlist -> "list" + | PC.TFresh -> "fresh" + | PC.TPure -> "pure" + | PC.TContext -> "context" + | PC.TTypedef -> "typedef" + | PC.TDeclarer -> "declarer" + | PC.TIterator -> "iterator" + | PC.TName -> "name" + | PC.TRuleName str -> "rule_name-"^str + | PC.TUsing -> "using" + | PC.TPathIsoFile str -> "path_iso_file-"^str + | PC.TDisable -> "disable" + | PC.TExtends -> "extends" + | PC.TDepends -> "depends" + | PC.TOn -> "on" + | PC.TEver -> "ever" + | PC.TNever -> "never" + | PC.TExists -> "exists" + | PC.TForall -> "forall" + | PC.TReverse -> "reverse" + | PC.TError -> "error" + | PC.TWords -> "words" + + | PC.TNothing -> "nothing" + + | PC.Tchar(clt) -> "char"^(line_type2c clt) + | PC.Tshort(clt) -> "short"^(line_type2c clt) + | PC.Tint(clt) -> "int"^(line_type2c clt) + | PC.Tdouble(clt) -> "double"^(line_type2c clt) + | PC.Tfloat(clt) -> "float"^(line_type2c clt) + | PC.Tlong(clt) -> "long"^(line_type2c clt) + | PC.Tvoid(clt) -> "void"^(line_type2c clt) + | PC.Tstruct(clt) -> "struct"^(line_type2c clt) + | PC.Tunion(clt) -> "union"^(line_type2c clt) + | PC.Tunsigned(clt) -> "unsigned"^(line_type2c clt) + | PC.Tsigned(clt) -> "signed"^(line_type2c clt) + | PC.Tstatic(clt) -> "static"^(line_type2c clt) + | PC.Tinline(clt) -> "inline"^(line_type2c clt) + | PC.Ttypedef(clt) -> "typedef"^(line_type2c clt) + | PC.Tattr(s,clt) -> s^(line_type2c clt) + | PC.Tauto(clt) -> "auto"^(line_type2c clt) + | PC.Tregister(clt) -> "register"^(line_type2c clt) + | PC.Textern(clt) -> "extern"^(line_type2c clt) + | PC.Tconst(clt) -> "const"^(line_type2c clt) + | PC.Tvolatile(clt) -> "volatile"^(line_type2c clt) + + | PC.TPragma(s) -> s + | PC.TIncludeL(s,clt) -> (pr "#include \"%s\"" s)^(line_type2c clt) + | PC.TIncludeNL(s,clt) -> (pr "#include <%s>" s)^(line_type2c clt) + | PC.TDefine(clt,_) -> "#define"^(line_type2c clt) + | PC.TDefineParam(clt,_,_) -> "#define_param"^(line_type2c clt) + | PC.TMinusFile(s,clt) -> (pr "--- %s" s)^(line_type2c clt) + | PC.TPlusFile(s,clt) -> (pr "+++ %s" s)^(line_type2c clt) + + | PC.TInc(clt) -> "++"^(line_type2c clt) + | PC.TDec(clt) -> "--"^(line_type2c clt) + + | PC.TIf(clt) -> "if"^(line_type2c clt) + | PC.TElse(clt) -> "else"^(line_type2c clt) + | PC.TWhile(clt) -> "while"^(line_type2c clt) + | PC.TFor(clt) -> "for"^(line_type2c clt) + | PC.TDo(clt) -> "do"^(line_type2c clt) + | PC.TSwitch(clt) -> "switch"^(line_type2c clt) + | PC.TCase(clt) -> "case"^(line_type2c clt) + | PC.TDefault(clt) -> "default"^(line_type2c clt) + | PC.TReturn(clt) -> "return"^(line_type2c clt) + | PC.TBreak(clt) -> "break"^(line_type2c clt) + | PC.TContinue(clt) -> "continue"^(line_type2c clt) + | PC.TGoto(clt) -> "goto"^(line_type2c clt) + | PC.TIdent(s,clt) -> (pr "ident-%s" s)^(line_type2c clt) + | PC.TTypeId(s,clt) -> (pr "typename-%s" s)^(line_type2c clt) + | PC.TDeclarerId(s,clt) -> (pr "declarername-%s" s)^(line_type2c clt) + | PC.TIteratorId(s,clt) -> (pr "iteratorname-%s" s)^(line_type2c clt) + | PC.TMetaDeclarer(_,_,_,clt) -> "declmeta"^(line_type2c clt) + | PC.TMetaIterator(_,_,_,clt) -> "itermeta"^(line_type2c clt) + + | PC.TSizeof(clt) -> "sizeof"^(line_type2c clt) + + | PC.TString(x,clt) -> x^(line_type2c clt) + | PC.TChar(x,clt) -> x^(line_type2c clt) + | PC.TFloat(x,clt) -> x^(line_type2c clt) + | PC.TInt(x,clt) -> x^(line_type2c clt) + + | PC.TOrLog(clt) -> "||"^(line_type2c clt) + | PC.TAndLog(clt) -> "&&"^(line_type2c clt) + | PC.TOr(clt) -> "|"^(line_type2c clt) + | PC.TXor(clt) -> "^"^(line_type2c clt) + | PC.TAnd (clt) -> "&"^(line_type2c clt) + | PC.TEqEq(clt) -> "=="^(line_type2c clt) + | PC.TNotEq(clt) -> "!="^(line_type2c clt) + | PC.TLogOp(op,clt) -> + (match op with + Ast.Inf -> "<" + | Ast.InfEq -> "<=" + | Ast.Sup -> ">" + | Ast.SupEq -> ">=" + | _ -> failwith "not possible") + ^(line_type2c clt) + | PC.TShOp(op,clt) -> + (match op with + Ast.DecLeft -> "<<" + | Ast.DecRight -> ">>" + | _ -> failwith "not possible") + ^(line_type2c clt) + | PC.TPlus(clt) -> "+"^(line_type2c clt) + | PC.TMinus(clt) -> "-"^(line_type2c clt) + | PC.TMul(clt) -> "*"^(line_type2c clt) + | PC.TDmOp(op,clt) -> + (match op with + Ast.Div -> "/" + | Ast.Mod -> "%" + | _ -> failwith "not possible") + ^(line_type2c clt) + | PC.TTilde (clt) -> "~"^(line_type2c clt) + + | PC.TMetaParam(_,_,clt) -> "parammeta"^(line_type2c clt) + | PC.TMetaParamList(_,_,_,clt) -> "paramlistmeta"^(line_type2c clt) + | PC.TMetaConst(_,_,_,_,clt) -> "constmeta"^(line_type2c clt) + | PC.TMetaErr(_,_,_,clt) -> "errmeta"^(line_type2c clt) + | PC.TMetaExp(_,_,_,_,clt) -> "expmeta"^(line_type2c clt) + | PC.TMetaIdExp(_,_,_,_,clt) -> "idexpmeta"^(line_type2c clt) + | PC.TMetaLocalIdExp(_,_,_,_,clt) -> "localidexpmeta"^(line_type2c clt) + | PC.TMetaExpList(_,_,_,clt) -> "explistmeta"^(line_type2c clt) + | PC.TMetaId(_,_,_,clt) -> "idmeta"^(line_type2c clt) + | PC.TMetaType(_,_,clt) -> "typemeta"^(line_type2c clt) + | PC.TMetaStm(_,_,clt) -> "stmmeta"^(line_type2c clt) + | PC.TMetaStmList(_,_,clt) -> "stmlistmeta"^(line_type2c clt) + | PC.TMetaFunc(_,_,_,clt) -> "funcmeta"^(line_type2c clt) + | PC.TMetaLocalFunc(_,_,_,clt) -> "funcmeta"^(line_type2c clt) + | PC.TMetaPos(_,_,_,clt) -> "posmeta" + | PC.TMPtVirg -> ";" + | PC.TArobArob -> "@@" + | PC.TArob -> "@" + | PC.TPArob -> "P@" + | PC.TScript -> "script" + + | PC.TWhen(clt) -> "WHEN"^(line_type2c clt) + | PC.TWhenTrue(clt) -> "WHEN TRUE"^(line_type2c clt) + | PC.TWhenFalse(clt) -> "WHEN FALSE"^(line_type2c clt) + | PC.TAny(clt) -> "ANY"^(line_type2c clt) + | PC.TStrict(clt) -> "STRICT"^(line_type2c clt) + | PC.TEllipsis(clt) -> "..."^(line_type2c clt) +(* + | PC.TCircles(clt) -> "ooo"^(line_type2c clt) + | PC.TStars(clt) -> "***"^(line_type2c clt) +*) + + | PC.TOEllipsis(clt) -> "<..."^(line_type2c clt) + | PC.TCEllipsis(clt) -> "...>"^(line_type2c clt) + | PC.TPOEllipsis(clt) -> "<+..."^(line_type2c clt) + | PC.TPCEllipsis(clt) -> "...+>"^(line_type2c clt) +(* + | PC.TOCircles(clt) -> " "ooo>"^(line_type2c clt) + | PC.TOStars(clt) -> "<***"^(line_type2c clt) + | PC.TCStars(clt) -> "***>"^(line_type2c clt) +*) + | PC.TBang0 -> "!" + | PC.TPlus0 -> "+" + | PC.TWhy0 -> "?" + + | PC.TWhy(clt) -> "?"^(line_type2c clt) + | PC.TDotDot(clt) -> ":"^(line_type2c clt) + | PC.TBang(clt) -> "!"^(line_type2c clt) + | PC.TOPar(clt) -> "("^(line_type2c clt) + | PC.TOPar0(clt) -> "("^(line_type2c clt) + | PC.TMid0(clt) -> "|"^(line_type2c clt) + | PC.TCPar(clt) -> ")"^(line_type2c clt) + | PC.TCPar0(clt) -> ")"^(line_type2c clt) + + | PC.TOBrace(clt) -> "{"^(line_type2c clt) + | PC.TCBrace(clt) -> "}"^(line_type2c clt) + | PC.TOCro(clt) -> "["^(line_type2c clt) + | PC.TCCro(clt) -> "]"^(line_type2c clt) + | PC.TOInit(clt) -> "{"^(line_type2c clt) + + | PC.TPtrOp(clt) -> "->"^(line_type2c clt) + + | PC.TEq(clt) -> "="^(line_type2c clt) + | PC.TAssign(_,clt) -> "=op"^(line_type2c clt) + | PC.TDot(clt) -> "."^(line_type2c clt) + | PC.TComma(clt) -> ","^(line_type2c clt) + | PC.TPtVirg(clt) -> ";"^(line_type2c clt) + + | PC.EOF -> "eof" + | PC.TLineEnd(clt) -> "line end" + | PC.TInvalid -> "invalid" + | PC.TFunDecl(clt) -> "fundecl" + + | PC.TIso -> "<=>" + | PC.TRightIso -> "=>" + | PC.TIsoTopLevel -> "TopLevel" + | PC.TIsoExpression -> "Expression" + | PC.TIsoArgExpression -> "ArgExpression" + | PC.TIsoTestExpression -> "TestExpression" + | PC.TIsoStatement -> "Statement" + | PC.TIsoDeclaration -> "Declaration" + | PC.TIsoType -> "Type" + | PC.TScriptData s -> s + +let print_tokens s tokens = + Printf.printf "%s\n" s; + List.iter (function x -> Printf.printf "%s " (token2c x)) tokens; + Printf.printf "\n\n"; + flush stdout + +type plus = PLUS | NOTPLUS | SKIP + +let plus_attachable (tok,_) = + match tok with + PC.Tchar(clt) | PC.Tshort(clt) | PC.Tint(clt) | PC.Tdouble(clt) + | PC.Tfloat(clt) | PC.Tlong(clt) | PC.Tvoid(clt) | PC.Tstruct(clt) + | PC.Tunion(clt) | PC.Tunsigned(clt) | PC.Tsigned(clt) | PC.Tstatic(clt) + | PC.Tinline(clt) | PC.Ttypedef(clt) | PC.Tattr(_,clt) + | PC.Tauto(clt) | PC.Tregister(clt) + | PC.Textern(clt) | PC.Tconst(clt) | PC.Tvolatile(clt) + + | PC.TIncludeL(_,clt) | PC.TIncludeNL(_,clt) | PC.TDefine(clt,_) + | PC.TDefineParam(clt,_,_) | PC.TMinusFile(_,clt) | PC.TPlusFile(_,clt) + + | PC.TInc(clt) | PC.TDec(clt) + + | PC.TIf(clt) | PC.TElse(clt) | PC.TWhile(clt) | PC.TFor(clt) | PC.TDo(clt) + | PC.TSwitch(clt) | PC.TCase(clt) | PC.TDefault(clt) | PC.TReturn(clt) + | PC.TBreak(clt) | PC.TContinue(clt) | PC.TGoto(clt) | PC.TIdent(_,clt) + | PC.TTypeId(_,clt) | PC.TDeclarerId(_,clt) | PC.TIteratorId(_,clt) + + | PC.TSizeof(clt) + + | PC.TString(_,clt) | PC.TChar(_,clt) | PC.TFloat(_,clt) | PC.TInt(_,clt) + + | PC.TOrLog(clt) | PC.TAndLog(clt) | PC.TOr(clt) | PC.TXor(clt) + | PC.TAnd (clt) | PC.TEqEq(clt) | PC.TNotEq(clt) | PC.TLogOp(_,clt) + | PC.TShOp(_,clt) | PC.TPlus(clt) | PC.TMinus(clt) | PC.TMul(clt) + | PC.TDmOp(_,clt) | PC.TTilde (clt) + + | PC.TMetaParam(_,_,clt) | PC.TMetaParamList(_,_,_,clt) + | PC.TMetaConst(_,_,_,_,clt) | PC.TMetaErr(_,_,_,clt) + | PC.TMetaExp(_,_,_,_,clt) | PC.TMetaIdExp(_,_,_,_,clt) + | PC.TMetaLocalIdExp(_,_,_,_,clt) + | PC.TMetaExpList(_,_,_,clt) + | PC.TMetaId(_,_,_,clt) + | PC.TMetaType(_,_,clt) | PC.TMetaStm(_,_,clt) + | PC.TMetaStmList(_,_,clt) | PC.TMetaFunc(_,_,_,clt) + | PC.TMetaLocalFunc(_,_,_,clt) + + | PC.TWhen(clt) | PC.TWhenTrue(clt) | PC.TWhenFalse(clt) + | PC.TAny(clt) | PC.TStrict(clt) | PC.TEllipsis(clt) + (* | PC.TCircles(clt) | PC.TStars(clt) *) + + | PC.TWhy(clt) | PC.TDotDot(clt) | PC.TBang(clt) | PC.TOPar(clt) + | PC.TCPar(clt) + + | PC.TOBrace(clt) | PC.TCBrace(clt) | PC.TOCro(clt) | PC.TCCro(clt) + | PC.TOInit(clt) + + | PC.TPtrOp(clt) + + | PC.TEq(clt) | PC.TAssign(_,clt) | PC.TDot(clt) | PC.TComma(clt) + | PC.TPtVirg(clt) -> + if line_type clt = D.PLUS then PLUS else NOTPLUS + + | PC.TOPar0(clt) | PC.TMid0(clt) | PC.TCPar0(clt) + | PC.TOEllipsis(clt) | PC.TCEllipsis(clt) + | PC.TPOEllipsis(clt) | PC.TPCEllipsis(clt) (* | PC.TOCircles(clt) + | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *) -> NOTPLUS + | PC.TMetaPos(nm,_,_,_) -> NOTPLUS + + | _ -> SKIP + +let get_clt (tok,_) = + match tok with + PC.Tchar(clt) | PC.Tshort(clt) | PC.Tint(clt) | PC.Tdouble(clt) + | PC.Tfloat(clt) | PC.Tlong(clt) | PC.Tvoid(clt) | PC.Tstruct(clt) + | PC.Tunion(clt) | PC.Tunsigned(clt) | PC.Tsigned(clt) | PC.Tstatic(clt) + | PC.Tinline(clt) | PC.Tattr(_,clt) | PC.Tauto(clt) | PC.Tregister(clt) + | PC.Textern(clt) | PC.Tconst(clt) | PC.Tvolatile(clt) + + | PC.TIncludeL(_,clt) | PC.TIncludeNL(_,clt) | PC.TDefine(clt,_) + | PC.TDefineParam(clt,_,_) | PC.TMinusFile(_,clt) | PC.TPlusFile(_,clt) + + | PC.TInc(clt) | PC.TDec(clt) + + | PC.TIf(clt) | PC.TElse(clt) | PC.TWhile(clt) | PC.TFor(clt) | PC.TDo(clt) + | PC.TSwitch(clt) | PC.TCase(clt) | PC.TDefault(clt) | PC.TReturn(clt) + | PC.TBreak(clt) | PC.TContinue(clt) | PC.TGoto(clt) | PC.TIdent(_,clt) + | PC.TTypeId(_,clt) | PC.TDeclarerId(_,clt) | PC.TIteratorId(_,clt) + + | PC.TSizeof(clt) + + | PC.TString(_,clt) | PC.TChar(_,clt) | PC.TFloat(_,clt) | PC.TInt(_,clt) + + | PC.TOrLog(clt) | PC.TAndLog(clt) | PC.TOr(clt) | PC.TXor(clt) + | PC.TAnd (clt) | PC.TEqEq(clt) | PC.TNotEq(clt) | PC.TLogOp(_,clt) + | PC.TShOp(_,clt) | PC.TPlus(clt) | PC.TMinus(clt) | PC.TMul(clt) + | PC.TDmOp(_,clt) | PC.TTilde (clt) + + | PC.TMetaParam(_,_,clt) | PC.TMetaParamList(_,_,_,clt) + | PC.TMetaConst(_,_,_,_,clt) | PC.TMetaErr(_,_,_,clt) + | PC.TMetaExp(_,_,_,_,clt) | PC.TMetaIdExp(_,_,_,_,clt) + | PC.TMetaLocalIdExp(_,_,_,_,clt) + | PC.TMetaExpList(_,_,_,clt) + | PC.TMetaId(_,_,_,clt) + | PC.TMetaType(_,_,clt) | PC.TMetaStm(_,_,clt) + | PC.TMetaStmList(_,_,clt) | PC.TMetaFunc(_,_,_,clt) + | PC.TMetaLocalFunc(_,_,_,clt) | PC.TMetaPos(_,_,_,clt) + + | PC.TWhen(clt) | PC.TWhenTrue(clt) | PC.TWhenFalse(clt) | + PC.TAny(clt) | PC.TStrict(clt) | PC.TEllipsis(clt) + (* | PC.TCircles(clt) | PC.TStars(clt) *) + + | PC.TWhy(clt) | PC.TDotDot(clt) | PC.TBang(clt) | PC.TOPar(clt) + | PC.TCPar(clt) + + | PC.TOBrace(clt) | PC.TCBrace(clt) | PC.TOCro(clt) | PC.TCCro(clt) + | PC.TOInit(clt) + + | PC.TPtrOp(clt) + + | PC.TEq(clt) | PC.TAssign(_,clt) | PC.TDot(clt) | PC.TComma(clt) + | PC.TPtVirg(clt) + + | PC.TOPar0(clt) | PC.TMid0(clt) | PC.TCPar0(clt) + | PC.TOEllipsis(clt) | PC.TCEllipsis(clt) + | PC.TPOEllipsis(clt) | PC.TPCEllipsis(clt) (* | PC.TOCircles(clt) + | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *) -> clt + + | _ -> failwith "no clt" + +let update_clt (tok,x) clt = + match tok with + PC.Tchar(_) -> (PC.Tchar(clt),x) + | PC.Tshort(_) -> (PC.Tshort(clt),x) + | PC.Tint(_) -> (PC.Tint(clt),x) + | PC.Tdouble(_) -> (PC.Tdouble(clt),x) + | PC.Tfloat(_) -> (PC.Tfloat(clt),x) + | PC.Tlong(_) -> (PC.Tlong(clt),x) + | PC.Tvoid(_) -> (PC.Tvoid(clt),x) + | PC.Tstruct(_) -> (PC.Tstruct(clt),x) + | PC.Tunion(_) -> (PC.Tunion(clt),x) + | PC.Tunsigned(_) -> (PC.Tunsigned(clt),x) + | PC.Tsigned(_) -> (PC.Tsigned(clt),x) + | PC.Tstatic(_) -> (PC.Tstatic(clt),x) + | PC.Tinline(_) -> (PC.Tinline(clt),x) + | PC.Ttypedef(_) -> (PC.Ttypedef(clt),x) + | PC.Tattr(s,_) -> (PC.Tattr(s,clt),x) + | PC.Tauto(_) -> (PC.Tauto(clt),x) + | PC.Tregister(_) -> (PC.Tregister(clt),x) + | PC.Textern(_) -> (PC.Textern(clt),x) + | PC.Tconst(_) -> (PC.Tconst(clt),x) + | PC.Tvolatile(_) -> (PC.Tvolatile(clt),x) + + | PC.TIncludeL(s,_) -> (PC.TIncludeL(s,clt),x) + | PC.TIncludeNL(s,_) -> (PC.TIncludeNL(s,clt),x) + | PC.TDefine(_,a) -> (PC.TDefine(clt,a),x) + | PC.TDefineParam(_,a,b) -> (PC.TDefineParam(clt,a,b),x) + | PC.TMinusFile(s,_) -> (PC.TMinusFile(s,clt),x) + | PC.TPlusFile(s,_) -> (PC.TPlusFile(s,clt),x) + + | PC.TInc(_) -> (PC.TInc(clt),x) + | PC.TDec(_) -> (PC.TDec(clt),x) + + | PC.TIf(_) -> (PC.TIf(clt),x) + | PC.TElse(_) -> (PC.TElse(clt),x) + | PC.TWhile(_) -> (PC.TWhile(clt),x) + | PC.TFor(_) -> (PC.TFor(clt),x) + | PC.TDo(_) -> (PC.TDo(clt),x) + | PC.TSwitch(_) -> (PC.TSwitch(clt),x) + | PC.TCase(_) -> (PC.TCase(clt),x) + | PC.TDefault(_) -> (PC.TDefault(clt),x) + | PC.TReturn(_) -> (PC.TReturn(clt),x) + | PC.TBreak(_) -> (PC.TBreak(clt),x) + | PC.TContinue(_) -> (PC.TContinue(clt),x) + | PC.TGoto(_) -> (PC.TGoto(clt),x) + | PC.TIdent(s,_) -> (PC.TIdent(s,clt),x) + | PC.TTypeId(s,_) -> (PC.TTypeId(s,clt),x) + | PC.TDeclarerId(s,_) -> (PC.TDeclarerId(s,clt),x) + | PC.TIteratorId(s,_) -> (PC.TIteratorId(s,clt),x) + + | PC.TSizeof(_) -> (PC.TSizeof(clt),x) + + | PC.TString(s,_) -> (PC.TString(s,clt),x) + | PC.TChar(s,_) -> (PC.TChar(s,clt),x) + | PC.TFloat(s,_) -> (PC.TFloat(s,clt),x) + | PC.TInt(s,_) -> (PC.TInt(s,clt),x) + + | PC.TOrLog(_) -> (PC.TOrLog(clt),x) + | PC.TAndLog(_) -> (PC.TAndLog(clt),x) + | PC.TOr(_) -> (PC.TOr(clt),x) + | PC.TXor(_) -> (PC.TXor(clt),x) + | PC.TAnd (_) -> (PC.TAnd (clt),x) + | PC.TEqEq(_) -> (PC.TEqEq(clt),x) + | PC.TNotEq(_) -> (PC.TNotEq(clt),x) + | PC.TLogOp(op,_) -> (PC.TLogOp(op,clt),x) + | PC.TShOp(op,_) -> (PC.TShOp(op,clt),x) + | PC.TPlus(_) -> (PC.TPlus(clt),x) + | PC.TMinus(_) -> (PC.TMinus(clt),x) + | PC.TMul(_) -> (PC.TMul(clt),x) + | PC.TDmOp(op,_) -> (PC.TDmOp(op,clt),x) + | PC.TTilde (_) -> (PC.TTilde (clt),x) + + | PC.TMetaParam(a,b,_) -> (PC.TMetaParam(a,b,clt),x) + | PC.TMetaParamList(a,b,c,_) -> (PC.TMetaParamList(a,b,c,clt),x) + | PC.TMetaConst(a,b,c,d,_) -> (PC.TMetaConst(a,b,c,d,clt),x) + | PC.TMetaErr(a,b,c,_) -> (PC.TMetaErr(a,b,c,clt),x) + | PC.TMetaExp(a,b,c,d,_) -> (PC.TMetaExp(a,b,c,d,clt),x) + | PC.TMetaIdExp(a,b,c,d,_) -> (PC.TMetaIdExp(a,b,c,d,clt),x) + | PC.TMetaLocalIdExp(a,b,c,d,_) -> (PC.TMetaLocalIdExp(a,b,c,d,clt),x) + | PC.TMetaExpList(a,b,c,_) -> (PC.TMetaExpList(a,b,c,clt),x) + | PC.TMetaId(a,b,c,_) -> (PC.TMetaId(a,b,c,clt),x) + | PC.TMetaType(a,b,_) -> (PC.TMetaType(a,b,clt),x) + | PC.TMetaStm(a,b,_) -> (PC.TMetaStm(a,b,clt),x) + | PC.TMetaStmList(a,b,_) -> (PC.TMetaStmList(a,b,clt),x) + | PC.TMetaFunc(a,b,c,_) -> (PC.TMetaFunc(a,b,c,clt),x) + | PC.TMetaLocalFunc(a,b,c,_) -> (PC.TMetaLocalFunc(a,b,c,clt),x) + + | PC.TWhen(_) -> (PC.TWhen(clt),x) + | PC.TWhenTrue(_) -> (PC.TWhenTrue(clt),x) + | PC.TWhenFalse(_) -> (PC.TWhenFalse(clt),x) + | PC.TAny(_) -> (PC.TAny(clt),x) + | PC.TStrict(_) -> (PC.TStrict(clt),x) + | PC.TEllipsis(_) -> (PC.TEllipsis(clt),x) +(* + | PC.TCircles(_) -> (PC.TCircles(clt),x) + | PC.TStars(_) -> (PC.TStars(clt),x) +*) + + | PC.TOEllipsis(_) -> (PC.TOEllipsis(clt),x) + | PC.TCEllipsis(_) -> (PC.TCEllipsis(clt),x) + | PC.TPOEllipsis(_) -> (PC.TPOEllipsis(clt),x) + | PC.TPCEllipsis(_) -> (PC.TPCEllipsis(clt),x) +(* + | PC.TOCircles(_) -> (PC.TOCircles(clt),x) + | PC.TCCircles(_) -> (PC.TCCircles(clt),x) + | PC.TOStars(_) -> (PC.TOStars(clt),x) + | PC.TCStars(_) -> (PC.TCStars(clt),x) +*) + + | PC.TWhy(_) -> (PC.TWhy(clt),x) + | PC.TDotDot(_) -> (PC.TDotDot(clt),x) + | PC.TBang(_) -> (PC.TBang(clt),x) + | PC.TOPar(_) -> (PC.TOPar(clt),x) + | PC.TOPar0(_) -> (PC.TOPar0(clt),x) + | PC.TMid0(_) -> (PC.TMid0(clt),x) + | PC.TCPar(_) -> (PC.TCPar(clt),x) + | PC.TCPar0(_) -> (PC.TCPar0(clt),x) + + | PC.TOBrace(_) -> (PC.TOBrace(clt),x) + | PC.TCBrace(_) -> (PC.TCBrace(clt),x) + | PC.TOCro(_) -> (PC.TOCro(clt),x) + | PC.TCCro(_) -> (PC.TCCro(clt),x) + | PC.TOInit(_) -> (PC.TOInit(clt),x) + + | PC.TPtrOp(_) -> (PC.TPtrOp(clt),x) + + | PC.TEq(_) -> (PC.TEq(clt),x) + | PC.TAssign(s,_) -> (PC.TAssign(s,clt),x) + | PC.TDot(_) -> (PC.TDot(clt),x) + | PC.TComma(_) -> (PC.TComma(clt),x) + | PC.TPtVirg(_) -> (PC.TPtVirg(clt),x) + + | PC.TLineEnd(_) -> (PC.TLineEnd(clt),x) + | PC.TFunDecl(_) -> (PC.TFunDecl(clt),x) + + | _ -> failwith "no clt" + + +(* ----------------------------------------------------------------------- *) + +let make_name prefix ln = Printf.sprintf "%s starting on line %d" prefix ln + +(* ----------------------------------------------------------------------- *) +(* Read tokens *) + +let wrap_lexbuf_info lexbuf = + (Lexing.lexeme lexbuf, Lexing.lexeme_start lexbuf) + +let tokens_all_full token table file get_ats lexbuf end_markers : + (bool * ((PC.token * (string * (int * int) * (int * int))) list)) = + try + let rec aux () = + let result = token lexbuf in + let info = (Lexing.lexeme lexbuf, + (table.(Lexing.lexeme_start lexbuf)), + (Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)) in + if result = PC.EOF + then + if get_ats + then failwith "unexpected end of file in a metavariable declaration" + else (false,[(result,info)]) + else if List.mem result end_markers + then (true,[(result,info)]) + else + let (more,rest) = aux() in + (more,(result, info)::rest) + in aux () + with + e -> pr2 (Common.error_message file (wrap_lexbuf_info lexbuf) ); raise e + +let tokens_all table file get_ats lexbuf end_markers : + (bool * ((PC.token * (string * (int * int) * (int * int))) list)) = + tokens_all_full Lexer_cocci.token table file get_ats lexbuf end_markers + +let tokens_script_all table file get_ats lexbuf end_markers : + (bool * ((PC.token * (string * (int * int) * (int * int))) list)) = + tokens_all_full Lexer_script.token table file get_ats lexbuf end_markers + +(* ----------------------------------------------------------------------- *) +(* Split tokens into minus and plus fragments *) + +let split t clt = + let (d,_,_,_,_,_,_,_) = clt in + match d with + D.MINUS | D.OPTMINUS | D.UNIQUEMINUS -> ([t],[]) + | D.PLUS -> ([],[t]) + | D.CONTEXT | D.UNIQUE | D.OPT -> ([t],[t]) + +let split_token ((tok,_) as t) = + match tok with + PC.TIdentifier | PC.TConstant | PC.TExpression | PC.TIdExpression + | PC.TStatement | PC.TPosition | PC.TPosAny + | PC.TFunction | PC.TTypedef | PC.TDeclarer | PC.TIterator | PC.TName + | PC.TType | PC.TParameter | PC.TLocal | PC.Tlist | PC.TFresh | PC.TPure + | PC.TContext | PC.TRuleName(_) | PC.TUsing | PC.TDisable | PC.TExtends + | PC.TPathIsoFile(_) + | PC.TDepends | PC.TOn | PC.TEver | PC.TNever | PC.TExists | PC.TForall + | PC.TReverse + | PC.TError | PC.TWords | PC.TNothing -> ([t],[t]) + + | PC.Tchar(clt) | PC.Tshort(clt) | PC.Tint(clt) | PC.Tdouble(clt) + | PC.Tfloat(clt) | PC.Tlong(clt) | PC.Tvoid(clt) | PC.Tstruct(clt) + | PC.Tunion(clt) | PC.Tunsigned(clt) | PC.Tsigned(clt) + | PC.Tstatic(clt) | PC.Tauto(clt) | PC.Tregister(clt) | PC.Textern(clt) + | PC.Tinline(clt) | PC.Ttypedef(clt) | PC.Tattr(_,clt) + | PC.Tconst(clt) | PC.Tvolatile(clt) -> split t clt + + | PC.TPragma(s) -> ([],[t]) (* only allowed in + *) + | PC.TPlusFile(s,clt) | PC.TMinusFile(s,clt) + | PC.TIncludeL(s,clt) | PC.TIncludeNL(s,clt) -> + split t clt + | PC.TDefine(clt,_) | PC.TDefineParam(clt,_,_) -> split t clt + + | PC.TIf(clt) | PC.TElse(clt) | PC.TWhile(clt) | PC.TFor(clt) | PC.TDo(clt) + | PC.TSwitch(clt) | PC.TCase(clt) | PC.TDefault(clt) + | PC.TSizeof(clt) + | PC.TReturn(clt) | PC.TBreak(clt) | PC.TContinue(clt) | PC.TGoto(clt) + | PC.TIdent(_,clt) + | PC.TTypeId(_,clt) | PC.TDeclarerId(_,clt) | PC.TIteratorId(_,clt) + | PC.TMetaConst(_,_,_,_,clt) | PC.TMetaExp(_,_,_,_,clt) + | PC.TMetaIdExp(_,_,_,_,clt) | PC.TMetaLocalIdExp(_,_,_,_,clt) + | PC.TMetaExpList(_,_,_,clt) + | PC.TMetaParam(_,_,clt) | PC.TMetaParamList(_,_,_,clt) + | PC.TMetaId(_,_,_,clt) | PC.TMetaType(_,_,clt) + | PC.TMetaStm(_,_,clt) | PC.TMetaStmList(_,_,clt) | PC.TMetaErr(_,_,_,clt) + | PC.TMetaFunc(_,_,_,clt) | PC.TMetaLocalFunc(_,_,_,clt) + | PC.TMetaDeclarer(_,_,_,clt) | PC.TMetaIterator(_,_,_,clt) -> split t clt + | PC.TMPtVirg | PC.TArob | PC.TArobArob | PC.TScript -> ([t],[t]) + | PC.TPArob | PC.TMetaPos(_,_,_,_) -> ([t],[]) + + | PC.TFunDecl(clt) + | PC.TWhen(clt) | PC.TWhenTrue(clt) | PC.TWhenFalse(clt) + | PC.TAny(clt) | PC.TStrict(clt) | PC.TLineEnd(clt) + | PC.TEllipsis(clt) (* | PC.TCircles(clt) | PC.TStars(clt) *) -> split t clt + + | PC.TOEllipsis(_) | PC.TCEllipsis(_) (* clt must be context *) + | PC.TPOEllipsis(_) | PC.TPCEllipsis(_) (* clt must be context *) +(* + | PC.TOCircles(_) | PC.TCCircles(_) (* clt must be context *) + | PC.TOStars(_) | PC.TCStars(_) (* clt must be context *) +*) + | PC.TBang0 | PC.TPlus0 | PC.TWhy0 -> + ([t],[t]) + + | PC.TWhy(clt) | PC.TDotDot(clt) + | PC.TBang(clt) | PC.TOPar(clt) | PC.TOPar0(clt) + | PC.TMid0(clt) | PC.TCPar(clt) | PC.TCPar0(clt) -> split t clt + + | PC.TInc(clt) | PC.TDec(clt) -> split t clt + + | PC.TString(_,clt) | PC.TChar(_,clt) | PC.TFloat(_,clt) | PC.TInt(_,clt) -> + split t clt + + | PC.TOrLog(clt) | PC.TAndLog(clt) | PC.TOr(clt) | PC.TXor(clt) + | PC.TAnd (clt) | PC.TEqEq(clt) | PC.TNotEq(clt) | PC.TLogOp(_,clt) + | PC.TShOp(_,clt) | PC.TPlus(clt) | PC.TMinus(clt) | PC.TMul(clt) + | PC.TDmOp(_,clt) | PC.TTilde (clt) -> split t clt + + | PC.TOBrace(clt) | PC.TCBrace(clt) | PC.TOInit(clt) -> split t clt + | PC.TOCro(clt) | PC.TCCro(clt) -> split t clt + + | PC.TPtrOp(clt) -> split t clt + + | PC.TEq(clt) | PC.TAssign(_,clt) | PC.TDot(clt) | PC.TComma(clt) + | PC.TPtVirg(clt) -> split t clt + + | PC.EOF | PC.TInvalid -> ([t],[t]) + + | PC.TIso | PC.TRightIso + | PC.TIsoExpression | PC.TIsoStatement | PC.TIsoDeclaration | PC.TIsoType + | PC.TIsoTopLevel | PC.TIsoArgExpression | PC.TIsoTestExpression -> + failwith "unexpected tokens" + | PC.TScriptData s -> ([t],[t]) + +let split_token_stream tokens = + let rec loop = function + [] -> ([],[]) + | token::tokens -> + let (minus,plus) = split_token token in + let (minus_stream,plus_stream) = loop tokens in + (minus@minus_stream,plus@plus_stream) in + loop tokens + +(* ----------------------------------------------------------------------- *) +(* Find function names *) +(* This addresses a shift-reduce problem in the parser, allowing us to +distinguish a function declaration from a function call even if the latter +has no return type. Undoubtedly, this is not very nice, but it doesn't +seem very convenient to refactor the grammar to get around the problem. *) + +let rec find_function_names = function + [] -> [] + | ((PC.TIdent(_,clt),info) as t1) :: ((PC.TOPar(_),_) as t2) :: rest + | ((PC.TMetaId(_,_,_,clt),info) as t1) :: ((PC.TOPar(_),_) as t2) :: rest + | ((PC.TMetaFunc(_,_,_,clt),info) as t1) :: ((PC.TOPar(_),_) as t2) :: rest + | ((PC.TMetaLocalFunc(_,_,_,clt),info) as t1)::((PC.TOPar(_),_) as t2)::rest + -> + let rec skip level = function + [] -> ([],false,[]) + | ((PC.TCPar(_),_) as t)::rest -> + let level = level - 1 in + if level = 0 + then ([t],true,rest) + else let (pre,found,post) = skip level rest in (t::pre,found,post) + | ((PC.TOPar(_),_) as t)::rest -> + let level = level + 1 in + let (pre,found,post) = skip level rest in (t::pre,found,post) + | ((PC.TArobArob,_) as t)::rest + | ((PC.TArob,_) as t)::rest + | ((PC.EOF,_) as t)::rest -> ([t],false,rest) + | t::rest -> + let (pre,found,post) = skip level rest in (t::pre,found,post) in + let (pre,found,post) = skip 1 rest in + (match (found,post) with + (true,((PC.TOBrace(_),_) as t3)::rest) -> + (PC.TFunDecl(clt),info) :: t1 :: t2 :: pre @ + t3 :: (find_function_names rest) + | _ -> t1 :: t2 :: pre @ find_function_names post) + | t :: rest -> t :: find_function_names rest + +(* ----------------------------------------------------------------------- *) +(* an attribute is an identifier that preceeds another identifier and + begins with __ *) + +let rec detect_attr l = + let is_id = function + (PC.TIdent(_,_),_) | (PC.TMetaId(_,_,_,_),_) | (PC.TMetaFunc(_,_,_,_),_) + | (PC.TMetaLocalFunc(_,_,_,_),_) -> true + | _ -> false in + let rec loop = function + [] -> [] + | [x] -> [x] + | ((PC.TIdent(nm,clt),info) as t1)::id::rest when is_id id -> + if String.length nm > 2 && String.sub nm 0 2 = "__" + then (PC.Tattr(nm,clt),info)::(loop (id::rest)) + else t1::(loop (id::rest)) + | x::xs -> x::(loop xs) in + loop l + +(* ----------------------------------------------------------------------- *) +(* Look for variable declarations where the name is a typedef name. +We assume that C code does not contain a multiplication as a top-level +statement. *) + +(* bug: once a type, always a type, even if the same name is later intended + to be used as a real identifier *) +let detect_types in_meta_decls l = + let is_delim infn = function + (PC.TOEllipsis(_),_) (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *) + | (PC.TPOEllipsis(_),_) (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *) + | (PC.TEllipsis(_),_) (* | (PC.TCircles(_),_) | (PC.TStars(_),_) *) + | (PC.TPtVirg(_),_) | (PC.TOBrace(_),_) | (PC.TOInit(_),_) + | (PC.TCBrace(_),_) + | (PC.TPure,_) | (PC.TContext,_) + | (PC.Tstatic(_),_) | (PC.Textern(_),_) + | (PC.Tinline(_),_) | (PC.Ttypedef(_),_) | (PC.Tattr(_),_) -> true + | (PC.TComma(_),_) when infn > 0 or in_meta_decls -> true + | (PC.TDotDot(_),_) when in_meta_decls -> true + | _ -> false in + let is_choices_delim = function + (PC.TOBrace(_),_) | (PC.TComma(_),_) -> true | _ -> false in + let is_id = function + (PC.TIdent(_,_),_) | (PC.TMetaId(_,_,_,_),_) | (PC.TMetaFunc(_,_,_,_),_) + | (PC.TMetaLocalFunc(_,_,_,_),_) -> true + | (PC.TMetaParam(_,_,_),_) + | (PC.TMetaParamList(_,_,_,_),_) + | (PC.TMetaConst(_,_,_,_,_),_) + | (PC.TMetaErr(_,_,_,_),_) + | (PC.TMetaExp(_,_,_,_,_),_) + | (PC.TMetaIdExp(_,_,_,_,_),_) + | (PC.TMetaLocalIdExp(_,_,_,_,_),_) + | (PC.TMetaExpList(_,_,_,_),_) + | (PC.TMetaType(_,_,_),_) + | (PC.TMetaStm(_,_,_),_) + | (PC.TMetaStmList(_,_,_),_) + | (PC.TMetaPos(_,_,_,_),_) -> in_meta_decls + | _ -> false in + let redo_id ident clt v = + !Data.add_type_name ident; + (PC.TTypeId(ident,clt),v) in + let rec loop start infn type_names = function + (* infn: 0 means not in a function header + > 0 means in a function header, after infn - 1 unmatched open parens*) + [] -> [] + | ((PC.TOBrace(clt),v)::_) as all when in_meta_decls -> + collect_choices type_names all (* never a function header *) + | delim::(PC.TIdent(ident,clt),v)::((PC.TMul(_),_) as x)::rest + when is_delim infn delim -> + let newid = redo_id ident clt v in + delim::newid::x::(loop false infn (ident::type_names) rest) + | delim::(PC.TIdent(ident,clt),v)::id::rest + when is_delim infn delim && is_id id -> + let newid = redo_id ident clt v in + delim::newid::id::(loop false infn (ident::type_names) rest) + | ((PC.TFunDecl(_),_) as fn)::rest -> + fn::(loop false 1 type_names rest) + | ((PC.TOPar(_),_) as lp)::rest when infn > 0 -> + lp::(loop false (infn + 1) type_names rest) + | ((PC.TCPar(_),_) as rp)::rest when infn > 0 -> + if infn - 1 = 1 + then rp::(loop false 0 type_names rest) (* 0 means not in fn header *) + else rp::(loop false (infn - 1) type_names rest) + | (PC.TIdent(ident,clt),v)::((PC.TMul(_),_) as x)::rest when start -> + let newid = redo_id ident clt v in + newid::x::(loop false infn (ident::type_names) rest) + | (PC.TIdent(ident,clt),v)::id::rest when start && is_id id -> + let newid = redo_id ident clt v in + newid::id::(loop false infn (ident::type_names) rest) + | (PC.TIdent(ident,clt),v)::rest when List.mem ident type_names -> + (PC.TTypeId(ident,clt),v)::(loop false infn type_names rest) + | ((PC.TIdent(ident,clt),v) as x)::rest -> + x::(loop false infn type_names rest) + | x::rest -> x::(loop false infn type_names rest) + and collect_choices type_names = function + [] -> [] (* should happen, but let the parser detect that *) + | (PC.TCBrace(clt),v)::rest -> + (PC.TCBrace(clt),v)::(loop false 0 type_names rest) + | delim::(PC.TIdent(ident,clt),v)::rest + when is_choices_delim delim -> + let newid = redo_id ident clt v in + delim::newid::(collect_choices (ident::type_names) rest) + | x::rest -> x::(collect_choices type_names rest) in + loop true 0 [] l + + +(* ----------------------------------------------------------------------- *) +(* Insert TLineEnd tokens at the end of a line that contains a WHEN. + WHEN is restricted to a single line, to avoid ambiguity in eg: + ... WHEN != x + +3 *) + +let token2line (tok,_) = + match tok with + PC.Tchar(clt) | PC.Tshort(clt) | PC.Tint(clt) | PC.Tdouble(clt) + | PC.Tfloat(clt) | PC.Tlong(clt) | PC.Tvoid(clt) | PC.Tstruct(clt) + | PC.Tunion(clt) | PC.Tunsigned(clt) | PC.Tsigned(clt) + | PC.Tstatic(clt) | PC.Tauto(clt) | PC.Tregister(clt) | PC.Textern(clt) + | PC.Tinline(clt) | PC.Ttypedef(clt) | PC.Tattr(_,clt) | PC.Tconst(clt) + | PC.Tvolatile(clt) + + | PC.TInc(clt) | PC.TDec(clt) + + | PC.TIf(clt) | PC.TElse(clt) | PC.TWhile(clt) | PC.TFor(clt) | PC.TDo(clt) + | PC.TSwitch (clt) | PC.TCase (clt) | PC.TDefault (clt) | PC.TSizeof (clt) + | PC.TReturn(clt) | PC.TBreak(clt) | PC.TContinue(clt) | PC.TGoto(clt) + | PC.TIdent(_,clt) + | PC.TTypeId(_,clt) | PC.TDeclarerId(_,clt) | PC.TIteratorId(_,clt) + | PC.TMetaDeclarer(_,_,_,clt) | PC.TMetaIterator(_,_,_,clt) + + | PC.TString(_,clt) | PC.TChar(_,clt) | PC.TFloat(_,clt) | PC.TInt(_,clt) + + | PC.TOrLog(clt) | PC.TAndLog(clt) | PC.TOr(clt) | PC.TXor(clt) + | PC.TAnd (clt) | PC.TEqEq(clt) | PC.TNotEq(clt) | PC.TLogOp(_,clt) + | PC.TShOp(_,clt) | PC.TPlus(clt) | PC.TMinus(clt) | PC.TMul(clt) + | PC.TDmOp(_,clt) | PC.TTilde (clt) + + | PC.TMetaParam(_,_,clt) | PC.TMetaParamList(_,_,_,clt) + | PC.TMetaConst(_,_,_,_,clt) | PC.TMetaExp(_,_,_,_,clt) + | PC.TMetaIdExp(_,_,_,_,clt) | PC.TMetaLocalIdExp(_,_,_,_,clt) + | PC.TMetaExpList(_,_,_,clt) + | PC.TMetaId(_,_,_,clt) | PC.TMetaType(_,_,clt) + | PC.TMetaStm(_,_,clt) | PC.TMetaStmList(_,_,clt) | PC.TMetaFunc(_,_,_,clt) + | PC.TMetaLocalFunc(_,_,_,clt) | PC.TMetaPos(_,_,_,clt) + + | PC.TFunDecl(clt) + | PC.TWhen(clt) | PC.TWhenTrue(clt) | PC.TWhenFalse(clt) + | PC.TAny(clt) | PC.TStrict(clt) | PC.TEllipsis(clt) + (* | PC.TCircles(clt) | PC.TStars(clt) *) + + | PC.TOEllipsis(clt) | PC.TCEllipsis(clt) + | PC.TPOEllipsis(clt) | PC.TPCEllipsis(clt) (*| PC.TOCircles(clt) + | PC.TCCircles(clt) | PC.TOStars(clt) | PC.TCStars(clt) *) + + | PC.TWhy(clt) | PC.TDotDot(clt) | PC.TBang(clt) | PC.TOPar(clt) + | PC.TOPar0(clt) | PC.TMid0(clt) | PC.TCPar(clt) + | PC.TCPar0(clt) + + | PC.TOBrace(clt) | PC.TCBrace(clt) | PC.TOCro(clt) | PC.TCCro(clt) + | PC.TOInit(clt) + + | PC.TPtrOp(clt) + + | PC.TDefine(clt,_) | PC.TDefineParam(clt,_,_) + | PC.TIncludeL(_,clt) | PC.TIncludeNL(_,clt) + + | PC.TEq(clt) | PC.TAssign(_,clt) | PC.TDot(clt) | PC.TComma(clt) + | PC.TPtVirg(clt) -> + let (_,line,_,_,_,_,_,_) = clt in Some line + + | _ -> None + +let rec insert_line_end = function + [] -> [] + | (((PC.TWhen(clt),q) as x)::xs) -> + x::(find_line_end true (token2line x) clt q xs) + | (((PC.TDefine(clt,_),q) as x)::xs) + | (((PC.TDefineParam(clt,_,_),q) as x)::xs) -> + x::(find_line_end false (token2line x) clt q xs) + | x::xs -> x::(insert_line_end xs) + +and find_line_end inwhen line clt q = function + (* don't know what 2nd component should be so just use the info of + the When. Also inherit - of when, if any *) + [] -> [(PC.TLineEnd(clt),q)] + | ((PC.TIdent("strict",clt),a) as x)::xs when token2line x = line -> + (PC.TStrict(clt),a) :: (find_line_end inwhen line clt q xs) + | ((PC.TIdent("STRICT",clt),a) as x)::xs when token2line x = line -> + (PC.TStrict(clt),a) :: (find_line_end inwhen line clt q xs) + | ((PC.TIdent("any",clt),a) as x)::xs when token2line x = line -> + (PC.TAny(clt),a) :: (find_line_end inwhen line clt q xs) + | ((PC.TIdent("ANY",clt),a) as x)::xs when token2line x = line -> + (PC.TAny(clt),a) :: (find_line_end inwhen line clt q xs) + | ((PC.TIdent("forall",clt),a) as x)::xs when token2line x = line -> + (PC.TForall,a) :: (find_line_end inwhen line clt q xs) + | ((PC.TIdent("exists",clt),a) as x)::xs when token2line x = line -> + (PC.TExists,a) :: (find_line_end inwhen line clt q xs) + | ((PC.TComma(clt),a) as x)::xs when token2line x = line -> + (PC.TComma(clt),a) :: (find_line_end inwhen line clt q xs) + | ((PC.TPArob,a) as x)::xs -> (* no line #, just assume on the same line *) + x :: (find_line_end inwhen line clt q xs) + | x::xs when token2line x = line -> x :: (find_line_end inwhen line clt q xs) + | xs -> (PC.TLineEnd(clt),q)::(insert_line_end xs) + +let rec translate_when_true_false = function + [] -> [] + | (PC.TWhen(clt),q)::((PC.TNotEq(_),_) as x)::(PC.TIdent("true",_),_)::xs -> + (PC.TWhenTrue(clt),q)::x::xs + | (PC.TWhen(clt),q)::((PC.TNotEq(_),_) as x)::(PC.TIdent("false",_),_)::xs -> + (PC.TWhenFalse(clt),q)::x::xs + | x::xs -> x :: (translate_when_true_false xs) + +(* ----------------------------------------------------------------------- *) +(* top level initializers: a sequence of braces followed by a dot *) + +let find_top_init tokens = + match tokens with + (PC.TOBrace(clt),q) :: rest -> + let rec dot_start acc = function + ((PC.TOBrace(_),_) as x) :: rest -> + dot_start (x::acc) rest + | ((PC.TDot(_),_) :: rest) as x -> + Some ((PC.TOInit(clt),q) :: (List.rev acc) @ x) + | l -> None in + let rec comma_end acc = function + ((PC.TCBrace(_),_) as x) :: rest -> + comma_end (x::acc) rest + | ((PC.TComma(_),_) :: rest) as x -> + Some ((PC.TOInit(clt),q) :: (List.rev x) @ acc) + | l -> None in + (match dot_start [] rest with + Some x -> x + | None -> + (match List.rev rest with + ((PC.EOF,_) as x)::rest -> + (match comma_end [x] rest with + Some x -> x + | None -> tokens) + | _ -> failwith "unexpected empty token list")) + | _ -> tokens + +(* ----------------------------------------------------------------------- *) +(* process pragmas: they can only be used in + code, and adjacent to +another + token. They are concatenated to the string representation of +that other token. *) + +let rec collect_all_pragmas collected = function + (PC.TPragma(s),_)::rest -> collect_all_pragmas (s::collected) rest + | l -> (List.rev collected,l) + +let rec collect_up_to_pragmas skipped = function + [] -> None (* didn't reach a pragma, so nothing to do *) + | ((PC.TPragma(s),_) as t)::rest -> + let (pragmas,rest) = collect_all_pragmas [] (t::rest) in + Some (List.rev skipped,pragmas,rest) + | x::xs -> + match plus_attachable x with + PLUS -> None + | NOTPLUS -> None + | SKIP -> collect_up_to_pragmas (x::skipped) xs + +let rec collect_up_to_plus skipped = function + [] -> failwith "nothing to attach a pragma to" + | x::xs -> + match plus_attachable x with + PLUS -> (List.rev skipped,x,xs) + | NOTPLUS -> failwith "nothing to attach a pragma to" + | SKIP -> collect_up_to_plus (x::skipped) xs + +let rec process_pragmas = function + [] -> [] + | ((PC.TPragma(s),_)::_) as l -> + let (pragmas,rest) = collect_all_pragmas [] l in + let (skipped,aft,rest) = collect_up_to_plus [] rest in + let (a,b,c,d,e,strbef,straft,pos) = get_clt aft in + skipped@ + (process_pragmas ((update_clt aft (a,b,c,d,e,pragmas,straft,pos))::rest)) + | bef::xs -> + (match plus_attachable bef with + PLUS -> + (match collect_up_to_pragmas [] xs with + Some(skipped,pragmas,rest) -> + let (a,b,c,d,e,strbef,straft,pos) = get_clt bef in + (update_clt bef (a,b,c,d,e,strbef,pragmas,pos)):: + skipped@(process_pragmas rest) + | None -> bef::(process_pragmas xs)) + | _ -> bef::(process_pragmas xs)) + +(* ----------------------------------------------------------------------- *) +(* Drop ... ... . This is only allowed in + code, and arises when there is +some - code between the ... *) +(* drop whens as well - they serve no purpose in + code and they cause +problems for drop_double_dots *) + +let rec drop_when = function + [] -> [] + | (PC.TWhen(clt),info)::xs -> + let rec loop = function + [] -> [] + | (PC.TLineEnd(_),info)::xs -> drop_when xs + | x::xs -> loop xs in + loop xs + | x::xs -> x::drop_when xs + +(* instead of dropping the double dots, we put TNothing in between them. +these vanish after the parser, but keeping all the ...s in the + code makes +it easier to align the + and - code in context_neg and in preparation for the +isomorphisms. This shouldn't matter because the context code of the + +slice is mostly ignored anyway *) +let rec drop_double_dots l = + let start = function + (PC.TOEllipsis(_),_) | (PC.TPOEllipsis(_),_) + (* | (PC.TOCircles(_),_) | (PC.TOStars(_),_) *) -> + true + | _ -> false in + let middle = function + (PC.TEllipsis(_),_) (* | (PC.TCircles(_),_) | (PC.TStars(_),_) *) -> true + | _ -> false in + let final = function + (PC.TCEllipsis(_),_) | (PC.TPCEllipsis(_),_) + (* | (PC.TCCircles(_),_) | (PC.TCStars(_),_) *) -> + true + | _ -> false in + let rec loop ((_,i) as prev) = function + [] -> [] + | x::rest when middle prev && middle x -> (PC.TNothing,i)::x::(loop x rest) + | x::rest when start prev && middle x -> (PC.TNothing,i)::x::(loop x rest) + | x::rest when start prev && final x -> (PC.TNothing,i)::x::(loop x rest) + | x::rest when middle prev && final x -> (PC.TNothing,i)::x::(loop x rest) + | x::rest -> x :: (loop x rest) in + match l with + [] -> [] + | (x::xs) -> x :: loop x xs + +let rec fix f l = + let cur = f l in + if l = cur then l else fix f cur + +(* ( | ... | ) also causes parsing problems *) + +exception Not_empty + +let rec drop_empty_thing starter middle ender = function + [] -> [] + | hd::rest when starter hd -> + let rec loop = function + x::rest when middle x -> loop rest + | x::rest when ender x -> rest + | _ -> raise Not_empty in + (match try Some(loop rest) with Not_empty -> None with + Some x -> drop_empty_thing starter middle ender x + | None -> hd :: drop_empty_thing starter middle ender rest) + | x::rest -> x :: drop_empty_thing starter middle ender rest + +let drop_empty_or = + drop_empty_thing + (function (PC.TOPar0(_),_) -> true | _ -> false) + (function (PC.TMid0(_),_) -> true | _ -> false) + (function (PC.TCPar0(_),_) -> true | _ -> false) + +let drop_empty_nest = drop_empty_thing + +(* ----------------------------------------------------------------------- *) +(* Read tokens *) + +let get_s_starts (_, (s,_,(starts, ends))) = + Printf.printf "%d %d\n" starts ends; (s, starts) + +let pop2 l = + let v = List.hd !l in + l := List.tl !l; + v + +let reinit _ = + PC.reinit (function _ -> PC.TArobArob (* a handy token *)) + (Lexing.from_function + (function buf -> function n -> raise Common.Impossible)) + +let parse_one str parsefn file toks = + let all_tokens = ref toks in + let cur_tok = ref (List.hd !all_tokens) in + + let lexer_function _ = + let (v, info) = pop2 all_tokens in + cur_tok := (v, info); + v in + + let lexbuf_fake = + Lexing.from_function + (function buf -> function n -> raise Common.Impossible) + in + + reinit(); + + try parsefn lexer_function lexbuf_fake + with + Lexer_cocci.Lexical s -> + failwith + (Printf.sprintf "%s: lexical error: %s\n =%s\n" str s + (Common.error_message file (get_s_starts !cur_tok) )) + | Parser_cocci_menhir.Error -> + failwith + (Printf.sprintf "%s: parse error: \n = %s\n" str + (Common.error_message file (get_s_starts !cur_tok) )) + | Semantic_cocci.Semantic s -> + failwith + (Printf.sprintf "%s: semantic error: %s\n =%s\n" str s + (Common.error_message file (get_s_starts !cur_tok) )) + + | e -> raise e + +let prepare_tokens tokens = + find_top_init + (translate_when_true_false (* after insert_line_end *) + (insert_line_end + (detect_types false (find_function_names (detect_attr tokens))))) + +let rec consume_minus_positions = function + [] -> [] + | x::(PC.TPArob,_)::(PC.TMetaPos(name,constraints,per,clt),_)::xs -> + let (arity,ln,lln,offset,col,strbef,straft,_) = get_clt x in + let name = Parse_aux.clt2mcode name clt in + let x = + update_clt x + (arity,ln,lln,offset,col,strbef,straft, + Ast0.MetaPos(name,constraints,per)) in + x::(consume_minus_positions xs) + | x::xs -> x::consume_minus_positions xs + +let any_modif rule = + let mcode x = + match Ast0.get_mcode_mcodekind x with + Ast0.MINUS _ | Ast0.PLUS -> true + | _ -> false in + let donothing r k e = k e in + let bind x y = x or y in + let option_default = false in + let fn = + V0.combiner bind option_default + mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode + mcode + donothing donothing donothing donothing donothing donothing + donothing donothing donothing donothing donothing donothing donothing + donothing donothing in + List.exists fn.V0.combiner_top_level rule + +let drop_last extra l = List.rev(extra@(List.tl(List.rev l))) + +let partition_either l = + let rec part_either left right = function + | [] -> (List.rev left, List.rev right) + | x :: l -> + (match x with + | Common.Left e -> part_either (e :: left) right l + | Common.Right e -> part_either left (e :: right) l) in + part_either [] [] l + +let get_metavars parse_fn table file lexbuf = + let rec meta_loop acc (* read one decl at a time *) = + let (_,tokens) = + tokens_all table file true lexbuf [PC.TArobArob;PC.TMPtVirg] in + let tokens = prepare_tokens tokens in + match tokens with + [(PC.TArobArob,_)] -> List.rev acc + | _ -> + let metavars = parse_one "meta" parse_fn file tokens in + meta_loop (metavars@acc) in + partition_either (meta_loop []) + +let get_script_metavars parse_fn table file lexbuf = + let rec meta_loop acc = + let (_, tokens) = + tokens_all table file true lexbuf [PC.TArobArob; PC.TMPtVirg] in + let tokens = prepare_tokens tokens in + match tokens with + [(PC.TArobArob, _)] -> List.rev acc + | _ -> + let metavar = parse_one "scriptmeta" parse_fn file tokens in + meta_loop (metavar :: acc) + in + meta_loop [] + +let get_rule_name parse_fn starts_with_name get_tokens file prefix = + Data.in_rule_name := true; + let mknm _ = make_name prefix (!Lexer_cocci.line) in + let name_res = + if starts_with_name + then + let (_,tokens) = get_tokens [PC.TArob] in + match parse_one "rule name" parse_fn file tokens with + Ast.CocciRulename (None,a,b,c,d,e) -> + Ast.CocciRulename (Some (mknm()),a,b,c,d,e) + | Ast.CocciRulename (Some nm,a,b,c,d,e) -> + (if List.mem nm reserved_names + then failwith (Printf.sprintf "invalid name %s\n" nm)); + Ast.CocciRulename (Some nm,a,b,c,d,e) + | Ast.ScriptRulename(s,deps) -> Ast.ScriptRulename(s,deps) + else + Ast.CocciRulename(Some(mknm()),Ast.NoDep,[],[],Ast.Undetermined,false) in + Data.in_rule_name := false; + name_res + +let parse_iso file = + let table = Common.full_charpos_to_pos file in + Common.with_open_infile file (fun channel -> + let lexbuf = Lexing.from_channel channel in + let get_tokens = tokens_all table file false lexbuf in + let res = + match get_tokens [PC.TArobArob;PC.TArob] with + (true,start) -> + let parse_start start = + let rev = List.rev start in + let (arob,_) = List.hd rev in + (arob = PC.TArob,List.rev(List.tl rev)) in + let (starts_with_name,start) = parse_start start in + let rec loop starts_with_name start = + (!Data.init_rule)(); + (* get metavariable declarations - have to be read before the + rest *) + let (rule_name,_,_,_,_,_) = + match get_rule_name PC.iso_rule_name starts_with_name get_tokens + file ("iso file "^file) with + Ast.CocciRulename (Some n,a,b,c,d,e) -> (n,a,b,c,d,e) + | _ -> failwith "Script rules cannot appear in isomorphism rules" + in + Ast0.rule_name := rule_name; + Data.in_meta := true; + let iso_metavars = + match get_metavars PC.iso_meta_main table file lexbuf with + (iso_metavars,[]) -> iso_metavars + | _ -> failwith "unexpected inheritance in iso" in + Data.in_meta := false; + (* get the rule *) + let (more,tokens) = + get_tokens + [PC.TIsoStatement;PC.TIsoExpression;PC.TIsoArgExpression; + PC.TIsoTestExpression; + PC.TIsoDeclaration;PC.TIsoType;PC.TIsoTopLevel] in + let next_start = List.hd(List.rev tokens) in + let dummy_info = ("",(-1,-1),(-1,-1)) in + let tokens = drop_last [(PC.EOF,dummy_info)] tokens in + let tokens = prepare_tokens (start@tokens) in + (* + print_tokens "iso tokens" tokens; + *) + let entry = parse_one "iso main" PC.iso_main file tokens in + let entry = List.map (List.map Test_exps.process_anything) entry in + if more + then (* The code below allows a header like Statement list, + which is more than one word. We don't have that any more, + but the code is left here in case it is put back. *) + match get_tokens [PC.TArobArob;PC.TArob] with + (true,start) -> + let (starts_with_name,start) = parse_start start in + (iso_metavars,entry,rule_name) :: + (loop starts_with_name (next_start::start)) + | _ -> failwith "isomorphism ends early" + else [(iso_metavars,entry,rule_name)] in + loop starts_with_name start + | (false,_) -> [] in + res) + +let parse_iso_files existing_isos iso_files extra_path = + let get_names = List.map (function (_,_,nm) -> nm) in + let old_names = get_names existing_isos in + Data.in_iso := true; + let (res,_) = + List.fold_left + (function (prev,names) -> + function file -> + Lexer_cocci.init (); + let file = + match file with + Common.Left(fl) -> Filename.concat extra_path fl + | Common.Right(fl) -> Filename.concat Config.path fl in + let current = parse_iso file in + let new_names = get_names current in + if List.exists (function x -> List.mem x names) new_names + then failwith (Printf.sprintf "repeated iso name found in %s" file); + (current::prev,new_names @ names)) + ([],old_names) iso_files in + Data.in_iso := false; + existing_isos@(List.concat (List.rev res)) + +let parse file = + let table = Common.full_charpos_to_pos file in + Common.with_open_infile file (fun channel -> + let lexbuf = Lexing.from_channel channel in + let get_tokens = tokens_all table file false lexbuf in + Data.in_prolog := true; + let initial_tokens = get_tokens [PC.TArobArob;PC.TArob] in + Data.in_prolog := false; + let res = + match initial_tokens with + (true,data) -> + (match List.rev data with + ((PC.TArobArob as x),_)::_ | ((PC.TArob as x),_)::_ -> + let iso_files = + parse_one "iso file names" PC.include_main file data in + + let parse_cocci_rule old_metas + (rule_name, dependencies, iso, dropiso, exists, is_expression) = + Ast0.rule_name := rule_name; + Data.inheritable_positions := + rule_name :: !Data.inheritable_positions; + + (* get metavariable declarations *) + Data.in_meta := true; + let (metavars, inherited_metavars) = + get_metavars PC.meta_main table file lexbuf in + Data.in_meta := false; + Hashtbl.add Data.all_metadecls rule_name metavars; + Hashtbl.add Lexer_cocci.rule_names rule_name (); + Hashtbl.add Lexer_cocci.all_metavariables rule_name + (Hashtbl.fold + (fun key v rest -> (key,v)::rest) + Lexer_cocci.metavariables []); + + (* get transformation rules *) + let (more, tokens) = get_tokens [PC.TArobArob; PC.TArob] in + let (minus_tokens, plus_tokens) = split_token_stream tokens in + + let minus_tokens = consume_minus_positions minus_tokens in + let minus_tokens = prepare_tokens minus_tokens in + let plus_tokens = prepare_tokens plus_tokens in + + (* + print_tokens "minus tokens" minus_tokens; + print_tokens "plus tokens" plus_tokens; + *) + + let plus_tokens = + process_pragmas + (fix (function x -> drop_double_dots (drop_empty_or x)) + (drop_when plus_tokens)) in + (* + print_tokens "plus tokens" plus_tokens; + Printf.printf "before minus parse\n"; + *) + let minus_res = + if is_expression + then parse_one "minus" PC.minus_exp_main file minus_tokens + else parse_one "minus" PC.minus_main file minus_tokens in + (* + Unparse_ast0.unparse minus_res; + Printf.printf "before plus parse\n"; + *) + let plus_res = + if !Flag.sgrep_mode2 + then (* not actually used for anything, except context_neg *) + List.map + (Iso_pattern.rebuild_mcode None).V0.rebuilder_top_level + minus_res + else + if is_expression + then parse_one "plus" PC.plus_exp_main file plus_tokens + else parse_one "plus" PC.plus_main file plus_tokens in + (* + Printf.printf "after plus parse\n"; + *) + + (if not !Flag.sgrep_mode2 && + (any_modif minus_res or any_modif plus_res) + then Data.inheritable_positions := []); + + Check_meta.check_meta rule_name old_metas inherited_metavars + metavars minus_res plus_res; + + (more, Ast0.CocciRule ((minus_res, metavars, + (iso, dropiso, dependencies, rule_name, exists)), + (plus_res, metavars)), metavars, tokens) in + + let parse_script_rule language old_metas deps = + let get_tokens = tokens_script_all table file false lexbuf in + + (* meta-variables *) + Data.in_meta := true; + let metavars = + get_script_metavars PC.script_meta_main table file lexbuf in + Data.in_meta := false; + + let exists_in old_metas (py,(r,m)) = + let test (rr,mr) x = + let (ro,vo) = Ast.get_meta_name x in + ro = rr && vo = mr in + List.exists (test (r,m)) old_metas in + + List.iter + (function x -> + let meta2c (r,n) = Printf.sprintf "%s.%s" r n in + if not (exists_in old_metas x) then + failwith + (Printf.sprintf + "Script references unknown meta-variable: %s" + (meta2c(snd x)))) + metavars; + + (* script code *) + let (more, tokens) = get_tokens [PC.TArobArob; PC.TArob] in + let data = + match List.hd tokens with + (PC.TScriptData(s),_) -> s + | (PC.TArobArob,_) | (PC.TArob,_) -> "" + | _ -> failwith "Malformed script rule" in + (more,Ast0.ScriptRule(language, deps, metavars, data),[],tokens) in + + let parse_rule old_metas starts_with_name = + let rulename = + get_rule_name PC.rule_name starts_with_name get_tokens file + "rule" in + match rulename with + Ast.CocciRulename (Some s, a, b, c, d, e) -> + parse_cocci_rule old_metas (s, a, b, c, d, e) + | Ast.ScriptRulename (l,deps) -> parse_script_rule l old_metas deps + | _ -> failwith "Malformed rule name" + in + + let rec loop old_metas starts_with_name = + (!Data.init_rule)(); + + let gen_starts_with_name more tokens = + more && + (match List.hd (List.rev tokens) with + (PC.TArobArob,_) -> false + | (PC.TArob,_) -> true + | _ -> failwith "unexpected token") + in + + let (more, rule, metavars, tokens) = + parse_rule old_metas starts_with_name in + if more then + rule:: + (loop (metavars @ old_metas) (gen_starts_with_name more tokens)) + else [rule]; + + in + + (iso_files, loop [] (x = PC.TArob)) + | _ -> failwith "unexpected code before the first rule\n") + | (false,[(PC.TArobArob,_)]) | (false,[(PC.TArob,_)]) -> + ([],([] : Ast0.parsed_rule list)) + | _ -> failwith "unexpected code before the first rule\n" in + res) + +(* parse to ast0 and then convert to ast *) +let process file isofile verbose = + let extra_path = Filename.dirname file in + Lexer_cocci.init(); + let (iso_files, rules) = parse file in + let std_isos = + match isofile with + None -> [] + | Some iso_file -> parse_iso_files [] [Common.Left iso_file] "" in + let global_isos = parse_iso_files std_isos iso_files extra_path in + let rules = Unitary_ast0.do_unitary rules in + let parsed = + List.map + (function + Ast0.ScriptRule (a,b,c,d) -> [([],Ast.ScriptRule (a,b,c,d))] + | Ast0.CocciRule + ((minus, metavarsm, + (iso, dropiso, dependencies, rule_name, exists)), + (plus, metavars)) -> + let chosen_isos = + parse_iso_files global_isos + (List.map (function x -> Common.Left x) iso) + extra_path in + let chosen_isos = + (* check that dropped isos are actually available *) + (try + let iso_names = + List.map (function (_,_,nm) -> nm) chosen_isos in + let local_iso_names = reserved_names @ iso_names in + let bad_dropped = + List.find + (function dropped -> + not (List.mem dropped local_iso_names)) + dropiso in + failwith + ("invalid iso name " ^ bad_dropped ^ " in " ^ rule_name) + with Not_found -> ()); + if List.mem "all" dropiso + then + if List.length dropiso = 1 + then [] + else failwith "disable all should only be by itself" + else (* drop those isos *) + List.filter + (function (_,_,nm) -> not (List.mem nm dropiso)) + chosen_isos in + List.iter Iso_compile.process chosen_isos; + let dropped_isos = + match reserved_names with + "all"::others -> + (match dropiso with + ["all"] -> others + | _ -> + List.filter (function x -> List.mem x dropiso) others) + | _ -> + failwith + "bad list of reserved names - all must be at start" in + let minus = Test_exps.process minus in + let minus = Compute_lines.compute_lines minus in + let plus = Compute_lines.compute_lines plus in + let is_exp = + (* only relevant to Flag.make_hrule *) + (* doesn't handle multiple minirules properly, but since + we don't really handle them in lots of other ways, it + doesn't seem very important *) + match plus with + [] -> [false] + | p::_ -> + [match Ast0.unwrap p with + Ast0.CODE c -> + (match List.map Ast0.unwrap (Ast0.undots c) with + [Ast0.Exp e] -> true | _ -> false) + | _ -> false] in + let minus = Arity.minus_arity minus in + let ((metavars,minus),function_prototypes) = + Function_prototypes.process + rule_name metavars dropped_isos minus plus in + (* warning! context_neg side-effects its arguments *) + let (m,p) = List.split (Context_neg.context_neg minus plus) in + Type_infer.type_infer p; + (if not !Flag.sgrep_mode2 then Insert_plus.insert_plus m p); + Type_infer.type_infer minus; + let (extra_meta, minus) = + Iso_pattern.apply_isos chosen_isos minus rule_name in + let minus = Comm_assoc.comm_assoc minus rule_name dropiso in + let minus = + if !Flag.sgrep_mode2 then minus + else Single_statement.single_statement minus in + let minus = Simple_assignments.simple_assignments minus in + let minus_ast = + Ast0toast.ast0toast rule_name dependencies dropped_isos + exists minus is_exp in + match function_prototypes with + None -> [(extra_meta @ metavars, minus_ast)] + | Some mv_fp -> + [(extra_meta @ metavars, minus_ast); mv_fp]) +(* Ast0.CocciRule ((minus, metavarsm, (iso, dropiso, dependencies, rule_name, exists)), (plus, metavars))*) + rules in + let parsed = List.concat parsed in + let disjd = Disjdistr.disj parsed in + + let (code,fvs,neg_pos,ua,pos) = Free_vars.free_vars disjd in + if !Flag_parsing_cocci.show_SP + then List.iter Pretty_print_cocci.unparse code; + + let grep_tokens = + Common.profile_code "get_constants" + (fun () -> Get_constants.get_constants code) in (* for grep *) + let glimpse_tokens2 = + Common.profile_code "get_glimpse_constants" + (fun () -> Get_constants2.get_constants code neg_pos) in(* for glimpse *) + (code,fvs,neg_pos,ua,pos,grep_tokens,glimpse_tokens2) diff --git a/parsing_cocci/.#type_infer.ml.1.55 b/parsing_cocci/.#type_infer.ml.1.55 new file mode 100644 index 0000000..1d566ea --- /dev/null +++ b/parsing_cocci/.#type_infer.ml.1.55 @@ -0,0 +1,359 @@ +(* +* Copyright 2005-2008, Ecole des Mines de Nantes, University of Copenhagen +* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller +* This file is part of Coccinelle. +* +* Coccinelle is free software: you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation, according to version 2 of the License. +* +* Coccinelle is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with Coccinelle. If not, see . +* +* The authors reserve the right to distribute this or future versions of +* Coccinelle under other licenses. +*) + + +module T = Type_cocci +module Ast = Ast_cocci +module Ast0 = Ast0_cocci +module V0 = Visitor_ast0 + +(* Type inference: +Just propagates information based on declarations. Could try to infer +more precise information about expression metavariables, but not sure it is +worth it. The most obvious goal is to distinguish between test expressions +that have pointer, integer, and boolean type when matching isomorphisms, +but perhaps other needs will become apparent. *) + +(* "functions" that return a boolean value *) +let bool_functions = ["likely";"unlikely"] + +let err wrapped ty s = + T.typeC ty; Format.print_newline(); + failwith (Printf.sprintf "line %d: %s" (Ast0.get_line wrapped) s) + +type id = Id of string | Meta of (string * string) + +let rec lub_type t1 t2 = + match (t1,t2) with + (None,None) -> None + | (None,Some t) -> t2 + | (Some t,None) -> t1 + | (Some t1,Some t2) -> + let rec loop = function + (T.Unknown,t2) -> t2 + | (t1,T.Unknown) -> t1 + | (T.ConstVol(cv1,ty1),T.ConstVol(cv2,ty2)) when cv1 = cv2 -> + T.ConstVol(cv1,loop(ty1,ty2)) + | (T.Pointer(ty1),T.Pointer(ty2)) -> + T.Pointer(loop(ty1,ty2)) + | (ty1,T.Pointer(ty2)) -> T.Pointer(ty2) + | (T.Pointer(ty1),ty2) -> T.Pointer(ty1) + | (T.Array(ty1),T.Array(ty2)) -> T.Array(loop(ty1,ty2)) + | (T.TypeName(s1),t2) -> t2 + | (t1,T.TypeName(s1)) -> t1 + | (t1,_) -> t1 in (* arbitrarily pick the first, assume type correct *) + Some (loop (t1,t2)) + +let lub_envs envs = + List.fold_left + (function acc -> + function env -> + List.fold_left + (function acc -> + function (var,ty) -> + let (relevant,irrelevant) = + List.partition (function (x,_) -> x = var) acc in + match relevant with + [] -> (var,ty)::acc + | [(x,ty1)] -> + (match lub_type (Some ty) (Some ty1) with + Some new_ty -> (var,new_ty)::irrelevant + | None -> irrelevant) + | _ -> failwith "bad type environment") + acc env) + [] envs + +let rec propagate_types env = + let option_default = None in + let bind x y = option_default in (* no generic way of combining types *) + + let mcode x = option_default in + + let ident r k i = + match Ast0.unwrap i with + Ast0.Id(id) -> + (try Some(List.assoc (Id(Ast0.unwrap_mcode id)) env) + with Not_found -> None) + | Ast0.MetaId(id,_,_) -> + (try Some(List.assoc (Meta(Ast0.unwrap_mcode id)) env) + with Not_found -> None) + | _ -> k i in + + let strip_cv = function + Some (T.ConstVol(_,t)) -> Some t + | t -> t in + + let expression r k e = + let res = k e in + let ty = + match Ast0.unwrap e with + Ast0.Ident(id) -> Ast0.set_type e res; res + | Ast0.Constant(const) -> + (match Ast0.unwrap_mcode const with + Ast.String(_) -> Some (T.Pointer(T.BaseType(T.CharType,None))) + | Ast.Char(_) -> Some (T.BaseType(T.CharType,None)) + | Ast.Int(_) -> Some (T.BaseType(T.IntType,None)) + | Ast.Float(_) -> Some (T.BaseType(T.FloatType,None))) + | Ast0.FunCall(fn,lp,args,rp) -> + (match Ast0.get_type fn with + Some (T.FunctionPointer(ty)) -> Some ty + | _ -> + (match Ast0.unwrap fn with + Ast0.Ident(id) -> + (match Ast0.unwrap id with + Ast0.Id(id) -> + if List.mem (Ast0.unwrap_mcode id) bool_functions + then Some(T.BaseType(T.BoolType,None)) + else None + | _ -> None) + | _ -> None)) + | Ast0.Assignment(exp1,op,exp2,_) -> + let ty = lub_type (Ast0.get_type exp1) (Ast0.get_type exp2) in + Ast0.set_type exp1 ty; Ast0.set_type exp2 ty; ty + | Ast0.CondExpr(exp1,why,Some exp2,colon,exp3) -> + let ty = lub_type (Ast0.get_type exp2) (Ast0.get_type exp3) in + Ast0.set_type exp2 ty; Ast0.set_type exp3 ty; ty + | Ast0.CondExpr(exp1,why,None,colon,exp3) -> Ast0.get_type exp3 + | Ast0.Postfix(exp,op) | Ast0.Infix(exp,op) -> (* op is dec or inc *) + Ast0.get_type exp + | Ast0.Unary(exp,op) -> + (match Ast0.unwrap_mcode op with + Ast.GetRef -> + (match Ast0.get_type exp with + None -> Some (T.Pointer(T.Unknown)) + | Some t -> Some (T.Pointer(t))) + | Ast.DeRef -> + (match Ast0.get_type exp with + Some (T.Pointer(t)) -> Some t + | _ -> None) + | Ast.UnPlus -> Ast0.get_type exp + | Ast.UnMinus -> Ast0.get_type exp + | Ast.Tilde -> Ast0.get_type exp + | Ast.Not -> Some(T.BaseType(T.BoolType,None))) + | Ast0.Nested(exp1,op,exp2) -> failwith "nested in type inf not possible" + | Ast0.Binary(exp1,op,exp2) -> + let ty1 = Ast0.get_type exp1 in + let ty2 = Ast0.get_type exp2 in + let same_type = function + (None,None) -> Some (T.BaseType(T.IntType,None)) + | (Some (T.Pointer ty1),Some ty2) -> + Some (T.Pointer ty1) + | (Some ty1,Some (T.Pointer ty2)) -> + Some (T.Pointer ty2) + | (t1,t2) -> + let ty = lub_type t1 t2 in + Ast0.set_type exp1 ty; Ast0.set_type exp2 ty; ty in + (match Ast0.unwrap_mcode op with + Ast.Arith(op) -> same_type (ty1, ty2) + | Ast.Logical(op) -> + let ty = lub_type ty1 ty2 in + Ast0.set_type exp1 ty; Ast0.set_type exp2 ty; + Some(T.BaseType(T.BoolType,None))) + | Ast0.Paren(lp,exp,rp) -> Ast0.get_type exp + | Ast0.ArrayAccess(exp1,lb,exp2,rb) -> + (match strip_cv (Ast0.get_type exp2) with + None -> Ast0.set_type exp2 (Some(T.BaseType(T.IntType,None))) + | Some(T.BaseType(T.IntType,None)) -> () + | Some (T.MetaType(_,_,_)) -> () + | Some (T.TypeName _) -> () + | Some ty -> err exp2 ty "bad type for an array index"); + (match strip_cv (Ast0.get_type exp1) with + None -> None + | Some (T.Array(ty)) -> Some ty + | Some (T.Pointer(ty)) -> Some ty + | Some (T.MetaType(_,_,_)) -> None + | Some x -> err exp1 x "ill-typed array reference") + | Ast0.RecordAccess(exp,pt,field) -> + (match strip_cv (Ast0.get_type exp) with + None -> None + | Some (T.StructUnionName(_,_,_)) -> None + | Some (T.TypeName(_)) -> None + | Some (T.MetaType(_,_,_)) -> None + | Some x -> err exp x "non-structure type in field ref") + | Ast0.RecordPtAccess(exp,ar,field) -> + (match strip_cv (Ast0.get_type exp) with + None -> None + | Some (T.Pointer(t)) -> + (match strip_cv (Some t) with + | Some (T.Unknown) -> None + | Some (T.MetaType(_,_,_)) -> None + | Some (T.TypeName(_)) -> None + | Some (T.StructUnionName(_,_,_)) -> None + | Some x -> + err exp (T.Pointer(t)) + "non-structure pointer type in field ref" + | _ -> failwith "not possible") + | Some (T.MetaType(_,_,_)) -> None + | Some (T.TypeName(_)) -> None + | Some x -> err exp x "non-structure pointer type in field ref") + | Ast0.Cast(lp,ty,rp,exp) -> Some(Ast0.ast0_type_to_type ty) + | Ast0.SizeOfExpr(szf,exp) -> Some(T.BaseType(T.IntType,None)) + | Ast0.SizeOfType(szf,lp,ty,rp) -> Some(T.BaseType(T.IntType,None)) + | Ast0.TypeExp(ty) -> None + | Ast0.MetaErr(name,_,_) -> None + | Ast0.MetaExpr(name,_,Some [ty],_,_) -> Some ty + | Ast0.MetaExpr(name,_,ty,_,_) -> None + | Ast0.MetaExprList(name,_,_) -> None + | Ast0.EComma(cm) -> None + | Ast0.DisjExpr(_,exp_list,_,_) -> + let types = List.map Ast0.get_type exp_list in + let combined = List.fold_left lub_type None types in + (match combined with + None -> None + | Some t -> + List.iter (function e -> Ast0.set_type e (Some t)) exp_list; + Some t) + | Ast0.NestExpr(starter,expr_dots,ender,None,multi) -> + let _ = r.V0.combiner_expression_dots expr_dots in None + | Ast0.NestExpr(starter,expr_dots,ender,Some e,multi) -> + let _ = r.V0.combiner_expression_dots expr_dots in + let _ = r.V0.combiner_expression e in None + | Ast0.Edots(_,None) | Ast0.Ecircles(_,None) | Ast0.Estars(_,None) -> + None + | Ast0.Edots(_,Some e) | Ast0.Ecircles(_,Some e) + | Ast0.Estars(_,Some e) -> + let _ = r.V0.combiner_expression e in None + | Ast0.OptExp(exp) -> Ast0.get_type exp + | Ast0.UniqueExp(exp) -> Ast0.get_type exp in + Ast0.set_type e ty; + ty in + + let donothing r k e = k e in + + let rec strip id = + match Ast0.unwrap id with + Ast0.Id(name) -> Id(Ast0.unwrap_mcode name) + | Ast0.MetaId(name,_,_) -> Meta(Ast0.unwrap_mcode name) + | Ast0.MetaFunc(name,_,_) -> Meta(Ast0.unwrap_mcode name) + | Ast0.MetaLocalFunc(name,_,_) -> Meta(Ast0.unwrap_mcode name) + | Ast0.OptIdent(id) -> strip id + | Ast0.UniqueIdent(id) -> strip id in + + let process_whencode notfn allfn exp = function + Ast0.WhenNot(x) -> let _ = notfn x in () + | Ast0.WhenAlways(x) -> let _ = allfn x in () + | Ast0.WhenModifier(_) -> () + | Ast0.WhenNotTrue(x) -> let _ = exp x in () + | Ast0.WhenNotFalse(x) -> let _ = exp x in () in + + (* assume that all of the declarations are at the beginning of a statement + list, which is required by C, but not actually required by the cocci + parser *) + let rec process_statement_list r acc = function + [] -> acc + | (s::ss) -> + (match Ast0.unwrap s with + Ast0.Decl(_,decl) -> + let rec process_decl decl = + match Ast0.unwrap decl with + Ast0.Init(_,ty,id,_,exp,_) -> + let _ = + (propagate_types acc).V0.combiner_initialiser exp in + [(strip id,Ast0.ast0_type_to_type ty)] + | Ast0.UnInit(_,ty,id,_) -> + [(strip id,Ast0.ast0_type_to_type ty)] + | Ast0.MacroDecl(_,_,_,_,_) -> [] + | Ast0.TyDecl(ty,_) -> [] + | Ast0.Typedef(_,_,_,_) -> [] + | Ast0.DisjDecl(_,disjs,_,_) -> + List.concat(List.map process_decl disjs) + | Ast0.Ddots(_,_) -> [] (* not in a statement list anyway *) + | Ast0.OptDecl(decl) -> process_decl decl + | Ast0.UniqueDecl(decl) -> process_decl decl in + let new_acc = (process_decl decl)@acc in + process_statement_list r new_acc ss + | Ast0.Dots(_,wc) -> + (* why is this case here? why is there none for nests? *) + List.iter + (process_whencode r.V0.combiner_statement_dots + r.V0.combiner_statement r.V0.combiner_expression) + wc; + process_statement_list r acc ss + | Ast0.Disj(_,statement_dots_list,_,_) -> + let new_acc = + lub_envs + (List.map + (function x -> process_statement_list r acc (Ast0.undots x)) + statement_dots_list) in + process_statement_list r new_acc ss + | _ -> + let _ = (propagate_types acc).V0.combiner_statement s in + process_statement_list r acc ss) in + + let statement_dots r k d = + match Ast0.unwrap d with + Ast0.DOTS(l) | Ast0.CIRCLES(l) | Ast0.STARS(l) -> + let _ = process_statement_list r env l in option_default in + let statement r k s = + match Ast0.unwrap s with + Ast0.FunDecl(_,fninfo,name,lp,params,rp,lbrace,body,rbrace) -> + let rec get_binding p = + match Ast0.unwrap p with + Ast0.Param(ty,Some id) -> + [(strip id,Ast0.ast0_type_to_type ty)] + | Ast0.OptParam(param) -> get_binding param + | _ -> [] in + let fenv = List.concat (List.map get_binding (Ast0.undots params)) in + (propagate_types (fenv@env)).V0.combiner_statement_dots body + | Ast0.IfThen(_,_,exp,_,_,_) | Ast0.IfThenElse(_,_,exp,_,_,_,_,_) + | Ast0.While(_,_,exp,_,_,_) | Ast0.Do(_,_,_,_,exp,_,_) + | Ast0.For(_,_,_,_,Some exp,_,_,_,_,_) | Ast0.Switch(_,_,exp,_,_,_,_) -> + let _ = k s in + let rec process_test exp = + match (Ast0.unwrap exp,Ast0.get_type exp) with + (Ast0.Edots(_,_),_) -> None + | (Ast0.NestExpr(_,_,_,_,_),_) -> None + | (Ast0.MetaExpr(_,_,_,_,_),_) -> + (* if a type is known, it is specified in the decl *) + None + | (Ast0.Paren(lp,exp,rp),None) -> process_test exp + | (_,None) -> Some (T.BaseType(T.IntType,None)) + | _ -> None in + let new_expty = process_test exp in + (match new_expty with + None -> () (* leave things as they are *) + | Some ty -> Ast0.set_type exp new_expty); + None + | _ -> k s + + and case_line r k c = + match Ast0.unwrap c with + Ast0.Default(def,colon,code) -> let _ = k c in None + | Ast0.Case(case,exp,colon,code) -> + let _ = k c in + (match Ast0.get_type exp with + None -> Ast0.set_type exp (Some (T.BaseType(T.IntType,None))) + | _ -> ()); + None + | Ast0.OptCase(case) -> k c in + + V0.combiner bind option_default + mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode + mcode + donothing donothing donothing statement_dots donothing donothing + ident expression donothing donothing donothing donothing statement + case_line donothing + +let type_infer code = + let prop = propagate_types [(Id("NULL"),T.Pointer(T.Unknown))] in + let fn = prop.V0.combiner_top_level in + let _ = List.map fn code in + () diff --git a/parsing_cocci/.depend b/parsing_cocci/.depend index 68b202b..d02e5f9 100644 --- a/parsing_cocci/.depend +++ b/parsing_cocci/.depend @@ -95,11 +95,13 @@ iso_compile.cmo: visitor_ast0.cmi ../commons/common.cmi ast_cocci.cmi \ iso_compile.cmx: visitor_ast0.cmx ../commons/common.cmx ast_cocci.cmx \ ast0_cocci.cmx iso_compile.cmi iso_pattern.cmo: visitor_ast0.cmi unparse_ast0.cmi type_cocci.cmi \ - flag_parsing_cocci.cmo ../globals/flag.cmo compute_lines.cmi \ - ../commons/common.cmi ast_cocci.cmi ast0_cocci.cmi iso_pattern.cmi + flag_parsing_cocci.cmo ../globals/flag.cmo \ + ../commons/ocamlextra/dumper.cmi compute_lines.cmi ../commons/common.cmi \ + ast_cocci.cmi ast0_cocci.cmi iso_pattern.cmi iso_pattern.cmx: visitor_ast0.cmx unparse_ast0.cmx type_cocci.cmx \ - flag_parsing_cocci.cmx ../globals/flag.cmx compute_lines.cmx \ - ../commons/common.cmx ast_cocci.cmx ast0_cocci.cmx iso_pattern.cmi + flag_parsing_cocci.cmx ../globals/flag.cmx \ + ../commons/ocamlextra/dumper.cmx compute_lines.cmx ../commons/common.cmx \ + ast_cocci.cmx ast0_cocci.cmx iso_pattern.cmi lexer_cocci.cmo: parser_cocci_menhir.cmi parse_aux.cmo ../globals/flag.cmo \ data.cmi ../commons/common.cmi ast_cocci.cmi ast0_cocci.cmi lexer_cocci.cmx: parser_cocci_menhir.cmx parse_aux.cmx ../globals/flag.cmx \ diff --git a/parsing_cocci/iso_pattern.ml b/parsing_cocci/iso_pattern.ml index 6b6875d..bf7bab0 100644 --- a/parsing_cocci/iso_pattern.ml +++ b/parsing_cocci/iso_pattern.ml @@ -1595,46 +1595,52 @@ let instantiate bindings mv_bindings = | _ -> failwith "plus not possible" in if was_meta && nomodif exp && nomodif e then - let rec negate e (*for rewrapping*) res (*code to process*) = + let idcont x = x in + let rec negate e (*for rewrapping*) res (*code to process*) k = + (* k accumulates parens, to keep negation outside if no + propagation is possible *) match Ast0.unwrap res with Ast0.Unary(e1,op) when Ast0.unwrap_mcode op = Ast.Not -> - Ast0.rewrap e (Ast0.unwrap e1) - | Ast0.Edots(_,_) -> Ast0.rewrap e (Ast0.unwrap res) + k (Ast0.rewrap e (Ast0.unwrap e1)) + | Ast0.Edots(_,_) -> k (Ast0.rewrap e (Ast0.unwrap res)) | Ast0.Paren(lp,e,rp) -> - Ast0.rewrap res (Ast0.Paren(lp,negate e e,rp)) + negate e e + (function x -> + k (Ast0.rewrap res (Ast0.Paren(lp,x,rp)))) | Ast0.Binary(e1,op,e2) -> let reb nop = Ast0.rewrap_mcode op (Ast.Logical(nop)) in - let invop = - match Ast0.unwrap_mcode op with - Ast.Logical(Ast.Inf) -> - Ast0.Binary(e1,reb Ast.SupEq,e2) - | Ast.Logical(Ast.Sup) -> - Ast0.Binary(e1,reb Ast.InfEq,e2) - | Ast.Logical(Ast.InfEq) -> - Ast0.Binary(e1,reb Ast.Sup,e2) - | Ast.Logical(Ast.SupEq) -> - Ast0.Binary(e1,reb Ast.Inf,e2) - | Ast.Logical(Ast.Eq) -> - Ast0.Binary(e1,reb Ast.NotEq,e2) - | Ast.Logical(Ast.NotEq) -> - Ast0.Binary(e1,reb Ast.Eq,e2) - | Ast.Logical(Ast.AndLog) -> - Ast0.Binary(negate e1 e1,reb Ast.OrLog, - negate e2 e2) - | Ast.Logical(Ast.OrLog) -> - Ast0.Binary(negate e1 e1,reb Ast.AndLog, - negate e2 e2) - | _ -> Ast0.Unary(res,Ast0.rewrap_mcode op Ast.Not) in - Ast0.rewrap e invop + let k1 x = k (Ast0.rewrap e x) in + (match Ast0.unwrap_mcode op with + Ast.Logical(Ast.Inf) -> + k1 (Ast0.Binary(e1,reb Ast.SupEq,e2)) + | Ast.Logical(Ast.Sup) -> + k1 (Ast0.Binary(e1,reb Ast.InfEq,e2)) + | Ast.Logical(Ast.InfEq) -> + k1 (Ast0.Binary(e1,reb Ast.Sup,e2)) + | Ast.Logical(Ast.SupEq) -> + k1 (Ast0.Binary(e1,reb Ast.Inf,e2)) + | Ast.Logical(Ast.Eq) -> + k1 (Ast0.Binary(e1,reb Ast.NotEq,e2)) + | Ast.Logical(Ast.NotEq) -> + k1 (Ast0.Binary(e1,reb Ast.Eq,e2)) + | Ast.Logical(Ast.AndLog) -> + k1 (Ast0.Binary(negate e1 e1 idcont,reb Ast.OrLog, + negate e2 e2 idcont)) + | Ast.Logical(Ast.OrLog) -> + k1 (Ast0.Binary(negate e1 e1 idcont,reb Ast.AndLog, + negate e2 e2 idcont)) + | _ -> + Ast0.rewrap e + (Ast0.Unary(k res,Ast0.rewrap_mcode op Ast.Not))) | Ast0.DisjExpr(lp,exps,mids,rp) -> (* use res because it is the transformed argument *) - let exps = List.map (function e -> negate e e) exps in + let exps = List.map (function e -> negate e e k) exps in Ast0.rewrap res (Ast0.DisjExpr(lp,exps,mids,rp)) | _ -> (*use e, because this might be the toplevel expression*) Ast0.rewrap e - (Ast0.Unary(res,Ast0.rewrap_mcode unop Ast.Not)) in - negate e exp + (Ast0.Unary(k res,Ast0.rewrap_mcode unop Ast.Not)) in + negate e exp idcont else e | _ -> e) | Ast0.Edots(d,_) -> diff --git a/parsing_cocci/parse_cocci.ml b/parsing_cocci/parse_cocci.ml index b661baf..212dcda 100644 --- a/parsing_cocci/parse_cocci.ml +++ b/parsing_cocci/parse_cocci.ml @@ -915,9 +915,9 @@ and find_line_end inwhen line clt q = function let rec translate_when_true_false = function [] -> [] | (PC.TWhen(clt),q)::((PC.TNotEq(_),_) as x)::(PC.TIdent("true",_),_)::xs -> - (PC.TWhenTrue(clt),q)::x::xs + (PC.TWhenTrue(clt),q)::x::(translate_when_true_false xs) | (PC.TWhen(clt),q)::((PC.TNotEq(_),_) as x)::(PC.TIdent("false",_),_)::xs -> - (PC.TWhenFalse(clt),q)::x::xs + (PC.TWhenFalse(clt),q)::x::(translate_when_true_false xs) | x::xs -> x :: (translate_when_true_false xs) (* ----------------------------------------------------------------------- *) @@ -1127,6 +1127,8 @@ let prepare_tokens tokens = let rec consume_minus_positions = function [] -> [] + | ((PC.TOPar0(_),_) as x)::xs | ((PC.TCPar0(_),_) as x)::xs + | ((PC.TMid0(_),_) as x)::xs -> x::consume_minus_positions xs | x::(PC.TPArob,_)::(PC.TMetaPos(name,constraints,per,clt),_)::xs -> let (arity,ln,lln,offset,col,strbef,straft,_) = get_clt x in let name = Parse_aux.clt2mcode name clt in diff --git a/parsing_cocci/type_infer.ml b/parsing_cocci/type_infer.ml index 1d566ea..11f2f0c 100644 --- a/parsing_cocci/type_infer.ml +++ b/parsing_cocci/type_infer.ml @@ -52,10 +52,13 @@ let rec lub_type t1 t2 = | (t1,T.Unknown) -> t1 | (T.ConstVol(cv1,ty1),T.ConstVol(cv2,ty2)) when cv1 = cv2 -> T.ConstVol(cv1,loop(ty1,ty2)) + + (* pad: in pointer arithmetic, as in ptr+1, the lub must be ptr *) | (T.Pointer(ty1),T.Pointer(ty2)) -> T.Pointer(loop(ty1,ty2)) | (ty1,T.Pointer(ty2)) -> T.Pointer(ty2) | (T.Pointer(ty1),ty2) -> T.Pointer(ty1) + | (T.Array(ty1),T.Array(ty2)) -> T.Array(loop(ty1,ty2)) | (T.TypeName(s1),t2) -> t2 | (t1,T.TypeName(s1)) -> t1 @@ -105,6 +108,7 @@ let rec propagate_types env = let res = k e in let ty = match Ast0.unwrap e with + (* pad: the type of id is set in the ident visitor *) Ast0.Ident(id) -> Ast0.set_type e res; res | Ast0.Constant(const) -> (match Ast0.unwrap_mcode const with @@ -112,6 +116,9 @@ let rec propagate_types env = | Ast.Char(_) -> Some (T.BaseType(T.CharType,None)) | Ast.Int(_) -> Some (T.BaseType(T.IntType,None)) | Ast.Float(_) -> Some (T.BaseType(T.FloatType,None))) + (* pad: note that in C can do either ptr(...) or ( *ptr)(...) + * so I am not sure this code is enough. + *) | Ast0.FunCall(fn,lp,args,rp) -> (match Ast0.get_type fn with Some (T.FunctionPointer(ty)) -> Some ty @@ -154,10 +161,13 @@ let rec propagate_types env = let ty2 = Ast0.get_type exp2 in let same_type = function (None,None) -> Some (T.BaseType(T.IntType,None)) + + (* pad: pointer arithmetic handling as in ptr+1 *) | (Some (T.Pointer ty1),Some ty2) -> Some (T.Pointer ty1) | (Some ty1,Some (T.Pointer ty2)) -> Some (T.Pointer ty2) + | (t1,t2) -> let ty = lub_type t1 t2 in Ast0.set_type exp1 ty; Ast0.set_type exp2 ty; ty in @@ -181,6 +191,7 @@ let rec propagate_types env = | Some (T.Pointer(ty)) -> Some ty | Some (T.MetaType(_,_,_)) -> None | Some x -> err exp1 x "ill-typed array reference") + (* pad: should handle structure one day and look 'field' in environment *) | Ast0.RecordAccess(exp,pt,field) -> (match strip_cv (Ast0.get_type exp) with None -> None @@ -272,7 +283,8 @@ let rec propagate_types env = [(strip id,Ast0.ast0_type_to_type ty)] | Ast0.MacroDecl(_,_,_,_,_) -> [] | Ast0.TyDecl(ty,_) -> [] - | Ast0.Typedef(_,_,_,_) -> [] + (* pad: should handle typedef one day and add a binding *) + | Ast0.Typedef(_,_,_,_) -> [] | Ast0.DisjDecl(_,disjs,_,_) -> List.concat(List.map process_decl disjs) | Ast0.Ddots(_,_) -> [] (* not in a statement list anyway *) diff --git a/pycaml/Makefile b/pycaml/Makefile index 8396eff..58f217a 100644 --- a/pycaml/Makefile +++ b/pycaml/Makefile @@ -15,13 +15,12 @@ LIBDIRS = $(PY_PREFIX)/lib/python$(PY_VERSION)/config INCDIRS = $(PY_PREFIX)/include/python$(PY_VERSION) OCAMLLDFLAGS = -linkall -all.opt: native-code-library byte-code-library pycaml.customtop - cp -f dllpycaml_stubs.so ../ +all.opt: native-code-library pycaml.customtop -all: byte-code-library pycaml.customtop - cp -f dllpycaml_stubs.so ../ +all: pycaml.customtop -pycaml.customtop: pycaml.cma +pycaml.customtop: byte-code-library + cp -f dllpycaml_stubs.so ../ ocamlmktop -o pycaml.customtop pycaml.cma clean:: diff --git a/python/coccilib/.cvsignore b/python/coccilib/.cvsignore new file mode 100644 index 0000000..0d20b64 --- /dev/null +++ b/python/coccilib/.cvsignore @@ -0,0 +1 @@ +*.pyc diff --git a/python/coccilib/coccigui/.cvsignore b/python/coccilib/coccigui/.cvsignore new file mode 100644 index 0000000..0d20b64 --- /dev/null +++ b/python/coccilib/coccigui/.cvsignore @@ -0,0 +1 @@ +*.pyc diff --git a/python/coccilib/output.py b/python/coccilib/output.py index b1efa8a..a33a45f 100644 --- a/python/coccilib/output.py +++ b/python/coccilib/output.py @@ -33,6 +33,12 @@ class Output: def finalise(self): pass + def print_main(self, p) : + print "* TODO [[view:%s::face=ovl-face1::linb=%s::colb=%s::cole=%s][%s::%s]]" % (p[0].file,p[0].line,p[0].column,p[0].column_end,p[0].file,p[0].line) + + def print_sec(self, msg, p) : + print "[[view:%s::face=ovl-face2::linb=%s::colb=%s::cole=%s][%s]]" % (p[0].file,p[0].line,p[0].column,p[0].column_end,msg) + class Console(Output): def __init__(self): pass diff --git a/tests/assert.c b/tests/assert.c new file mode 100644 index 0000000..be26666 --- /dev/null +++ b/tests/assert.c @@ -0,0 +1,10 @@ +xfs_dir2_data_free_t * +xfs_dir2_data_freefind( + xfs_dir2_data_t *d, /* data block */ + xfs_dir2_data_unused_t *dup) /* data unused entry */ +{ + if (off < be16_to_cpu(dfp->offset)) + ASSERT(off + be16_to_cpu(dup->length) <= be16_to_cpu(dfp->offset)); + else + ASSERT(be16_to_cpu(dfp->offset) + be16_to_cpu(dfp->length) <= off); +} diff --git a/tests/deftodo.c b/tests/deftodo.c new file mode 100644 index 0000000..ee5ba2d --- /dev/null +++ b/tests/deftodo.c @@ -0,0 +1,13 @@ +#define UNIT_TYPE int + +/* + * cpu_alloc area immediately follows the percpu area that is allocated for + * each processor. + */ +#define cpu_alloc_start ((int *)__per_cpu_end) + +void __init cpu_alloc_init(void) +{ + cpu_alloc_start = alloc_bootmem(nr_units * UNIT_SIZE); +} + diff --git a/tests/deftodo.cocci b/tests/deftodo.cocci new file mode 100644 index 0000000..79a0255 --- /dev/null +++ b/tests/deftodo.cocci @@ -0,0 +1,27 @@ +// A pci_get_slot is not matched by a pci_put_slot before an error return. +// +// Confidence: High +// Copyright: (C) Gilles Muller, Julia Lawall, EMN, DIKU. GPLv2. +// URL: http://www.emn.fr/x-info/coccinelle/get_slot.html +// options: -no_includes -include_headers + +@@ +expression E; +statement S; +@@ + +E = \(alloc_bootmem\|alloc_bootmem_low\|alloc_bootmem_pages\|alloc_bootmem_low_pages\)(...) +... when != E +( +- BUG_ON (E == NULL); +| +- if (E == NULL) S +) + +@@ +expression E,E1; +@@ + +E = \(alloc_bootmem\|alloc_bootmem_low\|alloc_bootmem_pages\|alloc_bootmem_low_pages\)(...) +... when != E +- memset(E,0,E1); diff --git a/tests/deftodo.res b/tests/deftodo.res new file mode 100644 index 0000000..ee5ba2d --- /dev/null +++ b/tests/deftodo.res @@ -0,0 +1,13 @@ +#define UNIT_TYPE int + +/* + * cpu_alloc area immediately follows the percpu area that is allocated for + * each processor. + */ +#define cpu_alloc_start ((int *)__per_cpu_end) + +void __init cpu_alloc_init(void) +{ + cpu_alloc_start = alloc_bootmem(nr_units * UNIT_SIZE); +} + diff --git a/tests/doubleswitch.c b/tests/doubleswitch.c new file mode 100644 index 0000000..4ee6511 --- /dev/null +++ b/tests/doubleswitch.c @@ -0,0 +1,19 @@ +void zfLnxRecvEth(zdev_t* dev, zbuf_t* buf, u16_t port) +{ +#ifdef ZM_AVOID_UDP_LARGE_PACKET_FAIL + zbuf_t *new_buf; + + foo(); + + switch(netif_rx(new_buf)) +#else + + switch(netif_rx(buf)) +#endif + { + case NET_RX_BAD: + break; + } + + return; +} diff --git a/tests/doubleswitch.cocci b/tests/doubleswitch.cocci new file mode 100644 index 0000000..880c705 --- /dev/null +++ b/tests/doubleswitch.cocci @@ -0,0 +1,4 @@ +@@ +@@ + +- foo(); diff --git a/tests/doubleswitch.res b/tests/doubleswitch.res new file mode 100644 index 0000000..76cb700 --- /dev/null +++ b/tests/doubleswitch.res @@ -0,0 +1,17 @@ +void zfLnxRecvEth(zdev_t* dev, zbuf_t* buf, u16_t port) +{ +#ifdef ZM_AVOID_UDP_LARGE_PACKET_FAIL + zbuf_t *new_buf; + + switch(netif_rx(new_buf)) +#else + + switch(netif_rx(buf)) +#endif + { + case NET_RX_BAD: + break; + } + + return; +} diff --git a/tools/bridge.ml b/tools/bridge.ml index 7df0b06..c3dcdfb 100644 --- a/tools/bridge.ml +++ b/tools/bridge.ml @@ -112,7 +112,7 @@ let collect_ors fp lines = [] -> failwith "not possible" | [x] -> (c,k@v) :: prev | (tag,_)::_ -> - let vs = + (*let vs = Printf.sprintf "%s:(%s)" tag (String.concat "|" (List.sort compare @@ -120,8 +120,8 @@ let collect_ors fp lines = let attempt = Printf.sprintf "%s: %s %s" c (String.concat " " (List.map (function (k,v) -> k^":"^v) k)) - vs in - if List.mem attempt fp + vs in*) + if true (*List.mem attempt fp*) then let vs = Printf.sprintf "\\\\\\\\\\(%s\\\\\\\\\\)" diff --git a/tools/distributed/.cvsignore b/tools/distributed/.cvsignore new file mode 100644 index 0000000..8f4805b --- /dev/null +++ b/tools/distributed/.cvsignore @@ -0,0 +1,2 @@ +cleanup +spatch_linux diff --git a/tools/distributed/spatch_linux_script b/tools/distributed/spatch_linux_script index 7124cd4..9b18870 100755 --- a/tools/distributed/spatch_linux_script +++ b/tools/distributed/spatch_linux_script @@ -7,5 +7,5 @@ setenv COCCINELLE_HOME ${HOME}/coccinelle # -allow_inconsistent_paths (spatch.opt -quiet -timeout 120 \ --dir /home/julia/linux-2.6 -use_glimpse -cocci_file $* > ${1:r}.${3}.out) \ +-dir /var/linuxes/linux-next -use_glimpse -cocci_file $* > ${1:r}.${3}.out) \ >& tmp.${1:r}.${3}.out -- 2.20.1