--- /dev/null
+(*
+* 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 <http://www.gnu.org/licenses/>.
+*
+* 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 <linux/serio.h>
+ *)
+
+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)
+
.depend
+test.ml
Makefile.config
spatch
+spatch.opt
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
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
-*- 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:
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
((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
-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
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
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
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
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
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
MYMPISRC=distribution.ml
MPISYSLIBS=mpi.cma
+
+#-----------------------------------------------------------------------------
+#pcre
+#REGEXPINCLUDES=-I +pcre
+REGEXPINCLUDES=-I ../ocamlpcre/lib
+MYREGEXPSRC=regexp.ml
+
#-----------------------------------------------------------------------------
# Other stuff
#-----------------------------------------------------------------------------
all_libs: gdbm bdb gui mpi backtrace
+#-----------------------------------------------------------------------------
gdbm: commons_gdbm.cma
gdbm.opt: commons_gdbm.cmxa
$(OCAMLOPT) -a -o $@ $^
+#-----------------------------------------------------------------------------
bdb:
$(MAKE) INCLUDESEXTRA="$(BDBINCLUDES)" commons_bdb.cma
bdb.opt:
+#-----------------------------------------------------------------------------
gui:
$(MAKE) INCLUDESEXTRA="$(GUIINCLUDES)" commons_gui.cma
gui.opt:
+#-----------------------------------------------------------------------------
mpi:
$(MAKE) INCLUDESEXTRA="$(MPIINCLUDES)" commons_mpi.cma
mpi.opt:
+#-----------------------------------------------------------------------------
python:
$(MAKE) INCLUDESEXTRA="$(PYINCLUDES)" commons_python.cma
python.opt:
$(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
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
* - 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.
*
* Extra packages
* - ocamlbdb
- * - ocamlgtk
+ * - ocamlgtk, and gtksourceview
* - ocamlgl
* - ocamlpython
* - ocamlagrep
* - 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.
*)
(*****************************************************************************)
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 ->
exception Here
exception ReturnExn
+exception MultiFound
+
exception WrongFormat of string
(* old: let _TODO () = failwith "TODO", now via fix_caml with raise Todo *)
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) *)
* -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 ...' ?
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 *)
(*****************************************************************************)
(*****************************************************************************)
-(* 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
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
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 =
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 *)
(* 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
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");
* 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
+let uncat xs file =
+ with_open_outfile file (fun (pr,_chan) ->
+ xs +> List.iter (fun s -> pr s; pr "\n");
+
+ )
+
+
+
(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] ... *)
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 *)
-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 () =
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 =
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
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 *)
(*****************************************************************************)
| 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) ->
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 _ -> ()
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 *)
[
"-nocheck_stack", Arg.Clear check_stack,
" ";
+ "-batch_mode", Arg.Set _batch_mode,
+ " no interactivity"
]
(* potentially other common options but not yet integrated:
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
exception Here
exception ReturnExn
+exception MultiFound
+
exception WrongFormat of string
val error_cant_have : 'a -> 'b
val exn_to_s : exn -> string
+(* alias *)
+val string_of_exn : exn -> string
(*****************************************************************************)
(* Environment *)
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 *)
(*****************************************************************************)
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
val relative_to_absolute : filename -> filename
+val is_relative: filename -> bool
+val is_absolute: filename -> bool
+
val filename_without_leading_path : string -> filename -> filename
(*****************************************************************************)
(*****************************************************************************)
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
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
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
* 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 *)
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 *)
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 *)
(*****************************************************************************)
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. *)
(*****************************************************************************)
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 *)
(('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
(*****************************************************************************)
(* 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 :
*)
+(* 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
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
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
| _ -> failwith "glimpse not found or bad version"
)
+let s_of_glimpse_options xs =
+ xs +> List.map s_of_glimpse_search +> Common.join " "
+
+
+(*****************************************************************************)
+(* Indexing *)
+(*****************************************************************************)
(*
* note:
* 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.
* 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:
* 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
(* 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
+*)
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 =
method assoc : int -> 'a
method delkey : int -> 'o
+ method keys: int list
+
(* osequence concrete instantiation of virtual methods *)
method first : 'a
method last : 'a
+open Common
+
open Ocollection
(* assoc, also called map or dictionnary *)
(* 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
in
o#replkey (k, f old)
+ method apply_with_default2 = fun k f default ->
+ o#apply_with_default k f default +> ignore
+
+
end
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
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);
+
(* effect version *)
method add2: 'a -> unit
+ method del2: 'a -> unit
+ method clear: unit
method fold : ('c -> 'a -> 'c) -> 'c -> 'c
* 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 *)
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;
!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
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
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
method assoc k = Mapb.find k data
method delkey k = {< data = Mapb.remove k data >}
+
+ method keys =
+ List.map fst (o#tolist)
end
method empty =
raise Todo
- method private add2 (k,v) =
+ method private addbis (k,v) =
(* pr2 (fkey k); *)
(* pr2 (debugv v); *)
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
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)
+
-(* !!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 *) ->
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
--- /dev/null
+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)
+
--- /dev/null
+(* !!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
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
method assoc : 'a -> 'b
method delkey : 'a -> 'o
+ method keys: 'a list
+
end
val create_dbm :
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
method assoc k = k
method delkey k = {< >}
+
+ method keys =
+ List.map fst (o#tolist)
+
end
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.
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 \
--- /dev/null
+# 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 <http://www.gnu.org/licenses/>.
+#
+# 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
--- /dev/null
+(*
+* 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 <http://www.gnu.org/licenses/>.
+*
+* 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
--- /dev/null
+(*
+* 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 <http://www.gnu.org/licenses/>.
+*
+* 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
../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 \
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 \
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 \
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"
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
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
(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,_,_) ->
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? *)
f_storage = stob;
f_attr = attrs;
f_body = body;
+ f_old_c_style = oldstyle; (* TODO *)
},
iidb::ioparenb::icparenb::iifakestart::iistob)
)
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
*)
--- /dev/null
+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";
+ )
+
+
+
+
--- /dev/null
+
+(* 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
-let version = "0.1.2"
+let version = "0.1.3"
let path =
try (Sys.getenv "COCCINELLE_HOME")
let currentfile = ref (None : string option)
let current_element = ref ""
-
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
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 \
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
# - 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 \
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
(* 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 *)
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;
(* 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
| 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 *)
* 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 =
f_storage: storage;
f_body: compound;
f_attr: attribute list; (* gccext: *)
+ f_old_c_style: declaration list option;
}
(* cppext: IfdefFunHeader TODO *)
| 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 *)
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
| OriginTok pi -> true
| _ -> false
+(* ------------------------------------------------------------------------- *)
type posrv = Real of Common.parse_info | Virt of virtual_position
let compare_pos ii1 ii2 =
* 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 =
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 *)
(*****************************************************************************)
| 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?");
+(* should maybe be in pretty_print_c ? *)
+
let s_of_inc_file inc_file =
match inc_file with
| Local xs -> xs +> Common.join "/"
| Simple (sopt, ft) -> sopt
| BitField (sopt, ft, expr) -> sopt
+
+let s_of_attr attr =
+ attr
+ +> List.map (fun (Attribute s, ii) -> s)
+ +> Common.join ","
+
| DuplicatedLabel of string
| NestedFunc
| ComputedGoto
+ | Define of Common.parse_info
exception Error of error
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
f_storage= sto;
f_body= compound;
f_attr= attrs;
+ f_old_c_style = oldstyle;
}, ii) = funcdef in
let iifunheader, iicompound =
(match ii with
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
| 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
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)
| DuplicatedLabel of string
| NestedFunc
| ComputedGoto
+ | Define of Common.parse_info
exception Error of error
(*
* 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
* ??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
(*****************************************************************************)
type cpp_option =
- | I of Common.filename
+ | I of Common.dirname
| D of string * string option
(* 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 =
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 "")
()
+(* ---------------------------------------------------------------------- *)
+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
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
(* 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
pr2 "CPPAST: too much candidates";
k cpp
)
+ )
| _ -> k cpp
);
}
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 ?
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
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
+
" <dir>"
]
+(*****************************************************************************)
+(* types *)
+(*****************************************************************************)
+let std_envir = ref (Filename.concat !path "config/envos/environment_splint.h")
+
+let cmdline_flags_envfile () =
+ [
+ "-env_file", Arg.Set_string std_envir,
+ " <file> (default=" ^ !std_envir ^ ")";
+ ]
+
+
(*****************************************************************************)
(* verbose *)
(*****************************************************************************)
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
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, " ";
"-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 *)
(*****************************************************************************)
" use .ast_raw pre-parsed cached C file";
]
-
(*****************************************************************************)
-
(* 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)
| 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
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
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 *)
(*****************************************************************************)
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
(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
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
(fun () -> mk_info_item2 a b)
+let info_same_line line xs =
+ xs +> List.filter (fun info -> Ast_c.line_of_info info = line)
(*****************************************************************************)
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
)
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
(* -------------------------------------------------- *)
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
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)]
)
in
let v = loop tr in
-
let v = consistency_checking v in
(v, stat)
*)
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
(* ---------------------------------------------------------------------- *)
(* 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
| ({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) }
(
((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)))))) ->
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);
f_storage = st;
f_body = cp;
f_attr = attrs;
+ f_old_c_style = old_style_opt;
},
([iis]++iifunc++iicp++[iistart]++iist)
| _ ->
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) *)*/
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
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
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
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
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 *)
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
* - 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.
| 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 *)
pass:int ->
Parser_c.token list -> Parser_c.token list -> Parser_c.token
+
* function to end of function.
*)
+ mutable problematic_lines:
+ (string list (* ident in error line *) * int (* line_error *)) list;
+
}
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:
)
)
+(*****************************************************************************)
+(* 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
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
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;
*)
pr2 "XXX";
- | F.MacroIterHeader (_s, ((s,es), ii)) ->
+ | F.MacroIterHeader (_s, ((s,es), ii)) ->
(*
iif ii;
vk_argument_list bigf es;
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;
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";
| F.IfdefEndif (info) ->
pp_ifdef_gen pr_elem pr_space info
+ | F.DefineTodo ->
+ pr2 "XXX";
+
| (
F.TopNode|F.EndNode|
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)
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
open Common
+open Ast_c
+
let score_path = "/home/pad/c-yacfe/tmp"
let tmpfile = "/tmp/output.c"
+
(*****************************************************************************)
(* Subsystem testing *)
(*****************************************************************************)
);
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
+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")
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
)
+(* ---------------------------------------------------------------------- *)
+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 =
()
Common.mk_action_1_arg test_cfg;
"-control_flow", " <file or file:function>",
Common.mk_action_1_arg test_cfg;
+ "-test_cfg_ifdef", " <file>",
+ Common.mk_action_1_arg test_cfg_ifdef;
"-parse_unparse", " <file>",
Common.mk_action_1_arg test_parse_unparse;
"-type_c", " <file>",
"-compare_c_hardcoded", " ",
Common.mk_action_0_arg test_compare_c_hardcoded;
+ "-test_attributes", " <file>",
+ Common.mk_action_1_arg test_attributes;
+ "-test_cpp", " <file>",
+ Common.mk_action_1_arg test_cpp;
+
+
+
"-xxx", " <file1> <>",
Common.mk_action_n_arg test_xxx;
]
(* 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
-> true
| _ -> false
+
+let is_ident_like = function
+ | TIdent _
+ | TypedefIdent _
+ | TIdentDefine _
+ | TDefParamVariadic _
+
+ | TUnknown _
+
+ | TMacroAttr _
+ | TMacroAttrStorage _
+ | TMacroStmt _
+ | TMacroString _
+ | TMacroDecl _
+ | TMacroStructDecl _
+ | TMacroDeclConst _
+ | TMacroIterator _
+ -> true
+
+ | _ -> false
+
+
(*****************************************************************************)
(* Visitors *)
(*****************************************************************************)
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
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
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
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* file license.txt for more details.
*)
+
open Common
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.
+ *
*)
(*****************************************************************************)
(* 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
*)
-(* 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
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
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" *)
+(* ------------------------------------------------------------ *)
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
| 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
)
-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) ->
(* 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)
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 |_ -> "<anon>")^
- "'");
- 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 |_ -> "<anon>"));
+ 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 |_ -> "<anon>")^
- "'");
- 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
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
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
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) ->
(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;
+ ()
+
-
-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
+
--- /dev/null
+(* 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
+
+
+
--- /dev/null
+
+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
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 *)
(*****************************************************************************)
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
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
iif iiptvirg;
| EmptyField -> ()
| MacroStructDeclTodo ->
- pr2 "MacroStructDeclTodo";
+ pr2_once "MacroStructDeclTodo";
()
| CppDirectiveStruct directive ->
f_storage = sto;
f_body = statxs;
f_attr = attrs;
+ f_old_c_style = oldstyle;
}, ii
->
iif ii;
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
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
| DefineInit ini -> vk_ini bigf ini
| DefineTodo ->
- pr2 "DefineTodo";
+ pr2_once "DefineTodo";
()
in f (k, bigf) defval
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)) ->
| F.DefineDoWhileZeroHeader (((),ii)) -> iif ii
| F.DefineTodo ->
- pr2 "DefineTodo";
+ pr2_once "DefineTodo";
()
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
(vk_struct_fieldkinds_s bigf onefield_multivars, iif iiptvirg))
| EmptyField -> EmptyField
| MacroStructDeclTodo ->
- pr2 "MacroStructDeclTodo";
+ pr2_once "MacroStructDeclTodo";
MacroStructDeclTodo
| CppDirectiveStruct directive ->
f_storage = sto;
f_body = statxs;
f_attr = attrs;
+ f_old_c_style = oldstyle;
}, ii
->
{f_name = s;
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
| DefineInit ini -> DefineInit (vk_ini_s bigf ini)
| DefineTodo ->
- pr2 "DefineTodo";
+ pr2_once "DefineTodo";
DefineTodo
in
f (k, bigf) x
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)) ->
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
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
--- /dev/null
+(*
+* 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 <http://www.gnu.org/licenses/>.
+*
+* 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
--- /dev/null
+(*
+* 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 <http://www.gnu.org/licenses/>.
+*
+* 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.TCCircles(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)
--- /dev/null
+(*
+* 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 <http://www.gnu.org/licenses/>.
+*
+* 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
+ ()
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 \
| _ -> 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,_) ->
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)
(* ----------------------------------------------------------------------- *)
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
| (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
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
| 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
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
| 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
[(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 *)
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::
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
--- /dev/null
+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);
+}
--- /dev/null
+#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);
+}
+
--- /dev/null
+// 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);
--- /dev/null
+#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);
+}
+
--- /dev/null
+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;
+}
--- /dev/null
+@@
+@@
+
+- foo();
--- /dev/null
+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;
+}
[] -> failwith "not possible"
| [x] -> (c,k@v) :: prev
| (tag,_)::_ ->
- let vs =
+ (*let vs =
Printf.sprintf "%s:(%s)" tag
(String.concat "|"
(List.sort compare
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\\\\\\\\\\)"
--- /dev/null
+cleanup
+spatch_linux
# -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
HCoop / bpt / coccinelle.git / commitdiff