[bpt/coccinelle.git] / parsing_c / unparse_hrule.ml

module Ast = Ast_cocci
module V = Visitor_ast

let error x s =
  failwith
    (Printf.sprintf "unparse_hrule: line: %d, %s" (Ast.get_line x) s)

let names = ref ([] : (string * int ref) list)

let started_files = ref ([] : (string * bool) list)
let typedefs = ref ([] : (string * string list ref) list)
let current_outfile = ref ""

let prefix = "_cocci_"

(* ----------------------------------------------------------------------- *)
(* Create rule to check for header include *)

let print_header_rule pr srcfile =
  match Str.split (Str.regexp "/") srcfile with
    [x] ->
      pr "@header@\n@@\n\n#include \"";
      pr x; pr "\"\n\n"; true
  | l ->
      let rec loop = function
	  [] -> false
	| [x] ->
	    pr "@header@\n@@\n\n#include \"";
	    pr x; pr "\"\n\n"; true
	| "include"::(x::xs) ->
	    pr "@header@\n@@\n\n#include <";
	    let x =
	      if Str.string_match (Str.regexp "asm-") x 0 then "asm" else x in
	    pr (String.concat "/" (x::xs));
	    pr ">\n\n"; true
	| x::xs -> loop xs in
      loop l

(* ----------------------------------------------------------------------- *)
(* Print check that we are not in the defining function *)

let print_check_rule pr function_name function_name_count header_req =
  (if header_req
  then pr (Printf.sprintf "@same_%s depends on header@\n" function_name_count)
  else pr (Printf.sprintf "@same_%s@\n" function_name_count));
  pr "position p;\n";
  pr "@@\n\n";
  pr function_name; pr "@p(...) { ... }\n\n"

(* ----------------------------------------------------------------------- *)
(* get parameters of the matched function *)

let rec env_lookup fn = function
    [] -> failwith "no binding"
  | (nm,vl)::rest when fn nm -> vl
  | _::rest -> env_lookup fn rest

let get_paramst env =
  let argname = ref ("","") in
  let fn ((_,nm) as name) =
    if nm = "ARGS"
    then (argname := name; true)
    else false in
  match env_lookup fn env with
    Ast_c.MetaParamListVal(paramst) -> (paramst,!argname)
  | _ -> failwith "not possible"

let get_function_name rule env =
  let donothing r k e = k e in
  let option_default = [] in
  let bind = Common.union_set in
  let do_any_list_list r any_list_list =
    List.fold_left
      (List.fold_left
	 (function prev -> function cur ->
	   bind (r.V.combiner_anything cur) prev))
      [] any_list_list in
  let mcode r mc =
    match Ast.get_mcodekind mc with
      Ast.MINUS(_,_,_,any_list_list) -> do_any_list_list r any_list_list
    | Ast.CONTEXT(_,any_befaft) ->
	(match any_befaft with
	  Ast.BEFORE(any_list_list) | Ast.AFTER(any_list_list) ->
	    do_any_list_list r any_list_list
	| Ast.BEFOREAFTER(ba,aa) ->
	    bind (do_any_list_list r ba) (do_any_list_list r aa)
	| Ast.NOTHING -> [])
    | Ast.PLUS -> [] in
  let expression r k e =
    bind (k e)
    (match Ast.unwrap e with
      Ast.FunCall(fn,lp,args,rp) ->
	(match Ast.undots args with
	  [e] ->
	    (match Ast.unwrap e with
	      Ast.MetaExprList(nm,_,_,_) ->
		(match Ast.unwrap_mcode nm with
		  (_,"ARGS") when Ast.get_mcodekind nm = Ast.PLUS ->
		    (match Ast.unwrap fn with
		      Ast.Ident(id) ->
			(match Ast.unwrap id with
			  Ast.MetaId(nm,_,_,_)
			| Ast.MetaFunc(nm,_,_,_)
			| Ast.MetaLocalFunc(nm,_,_,_) ->
			    [Ast.unwrap_mcode nm]
			| _ -> [])
		    | _ -> [])
		| _ -> [])
	    | _ -> [])
	| _ -> [])
    | _ -> []) in
  let names =
    (V.combiner bind option_default
      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).V.combiner_top_level
      rule in
  match names with
    [name] ->
      (match env_lookup (function nm -> nm = name) env with
	Ast_c.MetaIdVal(s) | Ast_c.MetaFuncVal(s)
      | Ast_c.MetaLocalFuncVal(s) -> s
      |	_ -> error rule "not possible")
  | _ -> error rule "inconsistent rule generation"

(* ----------------------------------------------------------------------- *)
(* Print metavariable declarations *)

let rec print_typedef pr = function
    (Ast_c.TypeName(name,_),_) ->
      let s = Ast_c.str_of_name name in
      let typedefs =
	try List.assoc !current_outfile !typedefs
	with Not_found ->
	  let td = ref [] in
	  typedefs := (!current_outfile,td)::!typedefs;
	  td in
      if not (List.mem s !typedefs)
      then (typedefs := s::!typedefs; pr "typedef "; pr s; pr ";\n")
  | (Ast_c.Pointer(_,ty),_) -> print_typedef pr ty
  | _ -> ()

let rewrap_str s ii =
  {ii with Ast_c.pinfo =
    (match ii.Ast_c.pinfo with
      Ast_c.OriginTok pi ->
	Ast_c.OriginTok { pi with Common.str = s;}
    | Ast_c.ExpandedTok (pi,vpi) ->
	Ast_c.ExpandedTok ({ pi with Common.str = s;},vpi)
    | Ast_c.FakeTok (_,vpi) -> Ast_c.FakeTok (s,vpi)
    | Ast_c.AbstractLineTok pi ->
	Ast_c.AbstractLineTok { pi with Common.str = s;})}

let rewrap_prefix_name prefix name = 
  match name with
  | Ast_c.RegularName (s, iiname) -> 
      let iis = Common.tuple_of_list1 iiname in 
      let iis' = rewrap_str (prefix^s) iis in
      Ast_c.RegularName (prefix ^ s, [iis'])
  | Ast_c.CppConcatenatedName _ | Ast_c.CppVariadicName _ 
  | Ast_c.CppIdentBuilder _
      -> raise Common.Todo


let print_metavar pr = function
  | {Ast_c.p_namei = Some name;
     p_type = (_,(Ast_c.Pointer(_,(Ast_c.BaseType(Ast_c.Void),_)),_));
    }
    ->
      let param = Ast_c.str_of_name name in
      pr ("expression "^prefix); pr param
  | ({Ast_c.p_namei = Some name; p_type = (_,ty)} : Ast_c.parameterType) ->

      let name' = rewrap_prefix_name prefix name in 

      print_typedef pr ty;

      Pretty_print_c.pp_param_gen
	(function x ->
	  let str = Ast_c.str_of_info x in
	  if not (List.mem str ["const";"volatile"])
	  then pr str)
	(function _ -> pr " ")
        {Ast_c.p_register = (false,[]);
         p_namei = Some name';
         p_type = (({Ast_c.const = false; Ast_c.volatile = false},[]),ty)
        }
  | _ -> failwith "function must have named parameters"

let make_exp = function
    ({Ast_c.p_namei = Some name; p_type = ty}, comma_ii) ->
      let no_info = (None,Ast_c.NotTest) in

      let name' = rewrap_prefix_name prefix name in

      let exp =
	((Ast_c.Ident (name'),ref no_info),Ast_c.noii) in
      (name,(Common.Left exp,comma_ii))
  | _ -> failwith "bad parameter"

let print_extra_typedefs pr env =
  let bigf =
    { Visitor_c.default_visitor_c with
      Visitor_c.ktype = (fun (k, bigf) ty -> 
	match ty with
	  (_,((Ast_c.TypeName(_,_),_) as ty)) -> print_typedef pr ty
	| _ -> k ty) } in
  List.iter
    (function (_,vl) ->
      match vl with
	Ast_c.MetaIdVal(_) | Ast_c.MetaFuncVal(_)
      | Ast_c.MetaLocalFuncVal(_) -> ()
      | Ast_c.MetaExprVal(exp) -> Visitor_c.vk_expr bigf exp
      | Ast_c.MetaExprListVal(args) -> Visitor_c.vk_argument_list bigf args
      | Ast_c.MetaParamVal(param) -> Visitor_c.vk_param bigf param
      | Ast_c.MetaParamListVal(params) -> Visitor_c.vk_param_list bigf params

      | Ast_c.MetaTypeVal(ty) -> Visitor_c.vk_type bigf ty
      | Ast_c.MetaInitVal(ty) -> Visitor_c.vk_ini bigf ty
      | Ast_c.MetaStmtVal(stm) -> Visitor_c.vk_statement bigf stm
      | Ast_c.MetaPosVal _ | Ast_c.MetaPosValList _
      | Ast_c.MetaListlenVal _ -> ())
    env

let rename argids env =
  let argenv = List.map (function name -> 
    let arg = Ast_c.str_of_name name in
    (arg,prefix^arg)
  ) argids in
  let lookup x = try List.assoc x argenv with Not_found -> x in
  let bigf =
    { Visitor_c.default_visitor_c_s with
    Visitor_c.kexpr_s = (fun (k,bigf) e -> 
      match e with
	((Ast_c.Ident (name), info), []) ->

          (* pad: assert is_regular_ident ? *)
          let s = Ast_c.str_of_name name in
          let ii = Ast_c.info_of_name name in
	  let new_name = lookup s in
          let new_id = Ast_c.RegularName (new_name, [rewrap_str new_name ii]) in
	  ((Ast_c.Ident (new_id), info), Ast_c.noii)
      | _ -> k e) } in
  List.map
    (function (x,vl) ->
      (x,
       match vl with
	 Ast_c.MetaIdVal(_) | Ast_c.MetaFuncVal(_)
       | Ast_c.MetaLocalFuncVal(_) -> vl
       | Ast_c.MetaExprVal(exp) ->
	   Ast_c.MetaExprVal(Visitor_c.vk_expr_s bigf exp)
       | Ast_c.MetaExprListVal(args) ->
	   Ast_c.MetaExprListVal(Visitor_c.vk_arguments_s bigf args)
       | Ast_c.MetaParamVal(param) ->
	   Ast_c.MetaParamVal(Visitor_c.vk_param_s bigf param)
       | Ast_c.MetaParamListVal(params) ->
	   Ast_c.MetaParamListVal(Visitor_c.vk_params_s bigf params)

       | Ast_c.MetaTypeVal(ty) ->
	   Ast_c.MetaTypeVal(Visitor_c.vk_type_s bigf ty)
       | Ast_c.MetaInitVal(ini) ->
	   Ast_c.MetaInitVal(Visitor_c.vk_ini_s bigf ini)
       | Ast_c.MetaStmtVal(stm) ->
	   Ast_c.MetaStmtVal(Visitor_c.vk_statement_s bigf stm)
       | Ast_c.MetaPosVal _ | Ast_c.MetaPosValList _
       | Ast_c.MetaListlenVal _ -> vl))
    env

let print_one_type pr env = function
    (Type_cocci.MetaType(name,keep,inherited)) as ty ->
      (try
	match List.assoc name env with
	  Ast_c.MetaTypeVal ty -> 
	    Pretty_print_c.pp_type_gen
	      (function x -> pr (Ast_c.str_of_info x))
	      (function _ -> pr " ")
	      ty
        | _ -> failwith "impossible"
      with Not_found -> pr (Type_cocci.type2c ty))
  | ty -> pr (Type_cocci.type2c ty)

let print_types pr env = function
    None -> ()
  | Some [ty] -> print_one_type pr env ty
  | Some types ->
      pr "{";
      Common.print_between (function _ -> pr ", ") (print_one_type pr env)
	types;
      pr "}"

let pp_meta_decl pr env decl =
  let no_arity = function Ast.NONE -> () | _ -> failwith "no arity allowed" in
  let pp_name (_,n) = pr n in
  match decl with
    Ast.MetaIdDecl(ar, name) ->
      no_arity ar; pr "identifier "; pp_name name; pr ";\n"
  | Ast.MetaFreshIdDecl(name, None) ->
      pr "fresh identifier "; pp_name name; pr ";\n"
  | Ast.MetaFreshIdDecl(name, Some x) ->
      pr "fresh identifier "; pp_name name; pr " = \""; pr x; pr "\";\n"
  | Ast.MetaTypeDecl(ar, name) ->
      no_arity ar; pr "type "; pp_name name; pr ";\n"
  | Ast.MetaInitDecl(ar, name) ->
      no_arity ar; pr "initialiser "; pp_name name; pr ";\n"
  | Ast.MetaListlenDecl(name) -> ()
  | Ast.MetaParamDecl(ar, name) ->
      no_arity ar; pr "parameter "; pp_name name; pr ";\n"
  | Ast.MetaParamListDecl(ar, name, None) ->
      no_arity ar; pr "parameter list "; pp_name name; pr ";\n"
  | Ast.MetaParamListDecl(ar, name, Some len) ->
      no_arity ar; pr "parameter list "; pp_name name;
      pr "["; pp_name len; pr "]"; pr ";\n"
  | Ast.MetaConstDecl(ar, name, types) ->
      no_arity ar; pr "constant "; print_types pr env types;
      pp_name name; pr ";\n"
  | Ast.MetaErrDecl(ar, name) ->
      no_arity ar; pr "error "; pp_name name; pr ";\n"
  | Ast.MetaExpDecl(ar, name, None) ->
      no_arity ar; pr "expression "; pp_name name; pr ";\n"
  | Ast.MetaExpDecl(ar, name, types) ->
      no_arity ar; print_types pr env types; pp_name name; pr ";\n"
  | Ast.MetaIdExpDecl(ar, name, types) ->
      no_arity ar; pr "idexpression ";
      print_types pr env types; pp_name name; pr ";\n"
  | Ast.MetaLocalIdExpDecl(ar, name, types) ->
      no_arity ar; pr "local idexpression ";
      print_types pr env types; pp_name name; pr ";\n"
  | Ast.MetaExpListDecl(ar, name, None) ->
      no_arity ar; pr "parameter list "; pp_name name; pr ";\n"
  | Ast.MetaExpListDecl(ar, name, Some len) ->
      no_arity ar; pr "parameter list ";
      pp_name name; pr "["; pp_name len; pr "]"; pr ";\n"
  | Ast.MetaStmDecl(ar, name) ->
      no_arity ar; pr "statement "; pp_name name; pr ";\n"
  | Ast.MetaStmListDecl(ar, name) ->
      no_arity ar; pr "statement list "; pp_name name; pr ";\n"
  | Ast.MetaFuncDecl(ar, name) ->
      no_arity ar; pr "function "; pp_name name; pr ";\n"
  | Ast.MetaLocalFuncDecl(ar, name) ->
      no_arity ar; pr "local function "; pp_name name; pr ";\n"
  | Ast.MetaPosDecl(ar, name) ->
      no_arity ar; pr "position "; pp_name name; pr ";\n"
  | Ast.MetaDeclarerDecl(ar, name) ->
      no_arity ar; pr "declarer "; pp_name name; pr ";\n"
  | Ast.MetaIteratorDecl(ar, name) ->
      no_arity ar; pr "iterator "; pp_name name; pr ";\n"

let print_metavariables pr local_metas paramst env header_req function_name =
  (if header_req
  then pr "@depends on header@\n"
  else pr "@@\n");
  pr (Printf.sprintf "position _p!=same_%s.p;\n" function_name);
  pr "identifier _f;\n";
  let rec loop = function
      [] | [{Ast_c.p_type =(_,(Ast_c.BaseType(Ast_c.Void),_))},_] -> []
    | ((first,_) as f)::rest ->
	print_metavar pr first; pr ";\n";
	(make_exp f) :: loop rest in
  let args = loop paramst in
  print_extra_typedefs pr env;
  List.iter (pp_meta_decl pr env) local_metas;
  pr "@@\n\n";
  args

(* ----------------------------------------------------------------------- *)
(* print_start/end *)

let print_start pr =
  pr "_f@_p(...) { <+...\n"

let print_end pr =
  pr "\n...+> }\n"

(* ----------------------------------------------------------------------- *)
(* Print call to the defined function *)

let print_param_name pr = function
    {Ast_c.p_namei = Some name} -> pr (Ast_c.str_of_name name)
  | _ -> failwith "function must have named parameters"

let pp_def_gen pr defn isexp =
  let {Ast_c.f_name = name; f_type = (_, (paramst, (b, iib))); } = defn in
  pr (Ast_c.str_of_name name); pr "(";
  (if b then failwith "not handling variable argument functions");
  (match paramst with
    [] | [{Ast_c.p_type = (_,(Ast_c.BaseType(Ast_c.Void),_))},_] -> ()
  | (first,_)::rest ->
      print_param_name pr first;
      List.iter (function (x,_) -> pr ", "; print_param_name pr x) rest);
  pr ")"; if not isexp then pr ";"

(* ----------------------------------------------------------------------- *)
(* Entry point *)

let pp_rule local_metas ast env srcfile =
  let (paramst,args_name) = get_paramst env in
  (* get rule information *)
  let (rule,printable) =
    match ast with
      Ast.CocciRule(_,_,[body],_,_) -> (* could extend to use attributes *)
	(body,
	 match Ast.unwrap body with
	   Ast.DECL(s) -> [[Ast.StatementTag s]]
	 | Ast.CODE(ss) -> [[Ast.StmtDotsTag ss]]
	 | _ -> error body "bad rule body")
    | _ -> failwith "bad rule" in
  (* create the output file *)
  let outdir =
    match !Flag.make_hrule with
      Some outdir -> outdir
    | None -> error rule "not possible" in
  let function_name = get_function_name rule env in
  let function_name_count =
    try
      let cell = List.assoc function_name !names in
      let ct = !cell in
      cell := ct + 1;
      function_name ^ (string_of_int ct)
    with Not_found ->
      let cell = ref 1 in
      names := (function_name,cell) :: !names;
      function_name in
  let outfile = outdir ^ "/" ^
    (if !Flag.hrule_per_file
    then Filename.chop_extension (Filename.basename srcfile)
    else function_name_count) in
  let escape_re = Str.regexp_string "/" in
  let dir = if !Flag.dir = "" then Filename.dirname srcfile else !Flag.dir in
  let outdirfile = Str.global_replace escape_re "_"dir in
  let outfile = outfile ^ outdirfile ^ ".cocci" in
  let saved_header_req =
    try let res = List.assoc outfile !started_files in Some res
    with Not_found -> None in
  current_outfile := outfile;
  Common.with_open_outfile_append outfile (fun (pr,chan) ->
    let header_req =
      match saved_header_req with
	Some x -> x
      |	None ->
	  let res = print_header_rule pr srcfile in
	  started_files := (outfile,res)::!started_files;
	  res in
    print_check_rule pr function_name function_name_count header_req;
    let args =
      print_metavariables pr local_metas paramst env header_req
	function_name_count in
    let (argids,args) = List.split args in
    let env = rename argids env in
    let env = (args_name,Ast_c.MetaExprListVal args)::env in
    print_start pr;
    (* for printing C tokens *)
    let pr_c info =
      match Ast_c.pinfo_of_info info with
	Ast_c.AbstractLineTok _ -> pr (Ast_c.str_of_info info)
      | Ast_c.FakeTok (s,_) -> pr s
      |	_ ->
	  Printf.printf "line: %s\n" (Common.dump info);
	  error rule "not an abstract line" in
    let pr_space _ = pr " " in
    Unparse_cocci.pp_list_list_any
      (env, (fun s _ _ _ -> pr s), pr_c, pr_space, pr_space, pr,
       (fun _ _ -> ()), (function _ -> ()), (function _ -> ()))
      true printable Unparse_cocci.InPlace;
    print_end pr;
    pr "\n")
Commit	Line	Data
faf9a90c C	1	module Ast = Ast_cocci
faf9a90c C	2	module V = Visitor_ast
34e49164	3
faf9a90c C	4	let error x s =
	5	failwith
	6	(Printf.sprintf "unparse_hrule: line: %d, %s" (Ast.get_line x) s)
34e49164	7
faf9a90c	8	let names = ref ([] : (string * int ref) list)
34e49164	9
0708f913 C	10	let started_files = ref ([] : (string * bool) list)
	11	let typedefs = ref ([] : (string * string list ref) list)
	12	let current_outfile = ref ""
	13
	14	let prefix = "_cocci_"
	15
34e49164 C	16	(* ----------------------------------------------------------------------- *)
	17	(* Create rule to check for header include *)
	18
	19	let print_header_rule pr srcfile =
	20	match Str.split (Str.regexp "/") srcfile with
	21	[x] ->
0708f913 C	22	pr "@header@\n@@\n\n#include \"";
0708f913 C	23	pr x; pr "\"\n\n"; true
34e49164 C	24	\| l ->
	25	let rec loop = function
	26	[] -> false
	27	\| [x] ->
0708f913 C	28	pr "@header@\n@@\n\n#include \"";
0708f913 C	29	pr x; pr "\"\n\n"; true
34e49164 C	30	\| "include"::(x::xs) ->
	31	pr "@header@\n@@\n\n#include <";
	32	let x =
	33	if Str.string_match (Str.regexp "asm-") x 0 then "asm" else x in
	34	pr (String.concat "/" (x::xs));
	35	pr ">\n\n"; true
	36	\| x::xs -> loop xs in
	37	loop l
	38
faf9a90c C	39	(* ----------------------------------------------------------------------- *)
	40	(* Print check that we are not in the defining function *)
	41
0708f913	42	let print_check_rule pr function_name function_name_count header_req =
faf9a90c	43	(if header_req
0708f913 C	44	then pr (Printf.sprintf "@same_%s depends on header@\n" function_name_count)
0708f913 C	45	else pr (Printf.sprintf "@same_%s@\n" function_name_count));
faf9a90c C	46	pr "position p;\n";
	47	pr "@@\n\n";
	48	pr function_name; pr "@p(...) { ... }\n\n"
	49
	50	(* ----------------------------------------------------------------------- *)
0708f913	51	(* get parameters of the matched function *)
faf9a90c C	52
	53	let rec env_lookup fn = function
	54	[] -> failwith "no binding"
	55	\| (nm,vl)::rest when fn nm -> vl
	56	\| _::rest -> env_lookup fn rest
	57
	58	let get_paramst env =
	59	let argname = ref ("","") in
	60	let fn ((_,nm) as name) =
	61	if nm = "ARGS"
	62	then (argname := name; true)
	63	else false in
	64	match env_lookup fn env with
	65	Ast_c.MetaParamListVal(paramst) -> (paramst,!argname)
	66	\| _ -> failwith "not possible"
	67
	68	let get_function_name rule env =
	69	let donothing r k e = k e in
	70	let option_default = [] in
	71	let bind = Common.union_set in
	72	let do_any_list_list r any_list_list =
	73	List.fold_left
	74	(List.fold_left
	75	(function prev -> function cur ->
	76	bind (r.V.combiner_anything cur) prev))
	77	[] any_list_list in
	78	let mcode r mc =
	79	match Ast.get_mcodekind mc with
708f4980	80	Ast.MINUS(_,_,_,any_list_list) -> do_any_list_list r any_list_list
faf9a90c C	81	\| Ast.CONTEXT(_,any_befaft) ->
	82	(match any_befaft with
	83	Ast.BEFORE(any_list_list) \| Ast.AFTER(any_list_list) ->
	84	do_any_list_list r any_list_list
	85	\| Ast.BEFOREAFTER(ba,aa) ->
	86	bind (do_any_list_list r ba) (do_any_list_list r aa)
	87	\| Ast.NOTHING -> [])
	88	\| Ast.PLUS -> [] in
	89	let expression r k e =
	90	bind (k e)
	91	(match Ast.unwrap e with
	92	Ast.FunCall(fn,lp,args,rp) ->
	93	(match Ast.undots args with
	94	[e] ->
	95	(match Ast.unwrap e with
	96	Ast.MetaExprList(nm,_,_,_) ->
	97	(match Ast.unwrap_mcode nm with
	98	(_,"ARGS") when Ast.get_mcodekind nm = Ast.PLUS ->
	99	(match Ast.unwrap fn with
	100	Ast.Ident(id) ->
	101	(match Ast.unwrap id with
	102	Ast.MetaId(nm,_,_,_)
	103	\| Ast.MetaFunc(nm,_,_,_)
	104	\| Ast.MetaLocalFunc(nm,_,_,_) ->
	105	[Ast.unwrap_mcode nm]
	106	\| _ -> [])
	107	\| _ -> [])
	108	\| _ -> [])
	109	\| _ -> [])
	110	\| _ -> [])
	111	\| _ -> []) in
	112	let names =
	113	(V.combiner bind option_default
	114	mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
	115	donothing donothing donothing donothing
	116	donothing expression donothing donothing donothing donothing donothing
	117	donothing donothing donothing donothing donothing).V.combiner_top_level
	118	rule in
	119	match names with
	120	[name] ->
	121	(match env_lookup (function nm -> nm = name) env with
	122	Ast_c.MetaIdVal(s) \| Ast_c.MetaFuncVal(s)
	123	\| Ast_c.MetaLocalFuncVal(s) -> s
	124	\| _ -> error rule "not possible")
	125	\| _ -> error rule "inconsistent rule generation"
	126
34e49164 C	127	(* ----------------------------------------------------------------------- *)
	128	(* Print metavariable declarations *)
	129
0708f913	130	let rec print_typedef pr = function
b1b2de81 C	131	(Ast_c.TypeName(name,_),_) ->
b1b2de81 C	132	let s = Ast_c.str_of_name name in
0708f913 C	133	let typedefs =
	134	try List.assoc !current_outfile !typedefs
	135	with Not_found ->
	136	let td = ref [] in
	137	typedefs := (!current_outfile,td)::!typedefs;
	138	td in
34e49164 C	139	if not (List.mem s !typedefs)
34e49164 C	140	then (typedefs := s::!typedefs; pr "typedef "; pr s; pr ";\n")
0708f913	141	\| (Ast_c.Pointer(_,ty),_) -> print_typedef pr ty
34e49164 C	142	\| _ -> ()
34e49164 C	143
faf9a90c C	144	let rewrap_str s ii =
	145	{ii with Ast_c.pinfo =
	146	(match ii.Ast_c.pinfo with
	147	Ast_c.OriginTok pi ->
	148	Ast_c.OriginTok { pi with Common.str = s;}
	149	\| Ast_c.ExpandedTok (pi,vpi) ->
	150	Ast_c.ExpandedTok ({ pi with Common.str = s;},vpi)
	151	\| Ast_c.FakeTok (_,vpi) -> Ast_c.FakeTok (s,vpi)
	152	\| Ast_c.AbstractLineTok pi ->
	153	Ast_c.AbstractLineTok { pi with Common.str = s;})}
	154
b1b2de81 C	155	let rewrap_prefix_name prefix name =
	156	match name with
	157	\| Ast_c.RegularName (s, iiname) ->
	158	let iis = Common.tuple_of_list1 iiname in
	159	let iis' = rewrap_str (prefix^s) iis in
	160	Ast_c.RegularName (prefix ^ s, [iis'])
	161	\| Ast_c.CppConcatenatedName _ \| Ast_c.CppVariadicName _
	162	\| Ast_c.CppIdentBuilder _
	163	-> raise Common.Todo
	164
	165
0708f913	166	let print_metavar pr = function
b1b2de81 C	167	\| {Ast_c.p_namei = Some name;
	168	p_type = (_,(Ast_c.Pointer(_,(Ast_c.BaseType(Ast_c.Void),_)),_));
	169	}
34e49164	170	->
b1b2de81	171	let param = Ast_c.str_of_name name in
0708f913	172	pr ("expression "^prefix); pr param
b1b2de81 C	173	\| ({Ast_c.p_namei = Some name; p_type = (_,ty)} : Ast_c.parameterType) ->
	174
	175	let name' = rewrap_prefix_name prefix name in
	176
0708f913	177	print_typedef pr ty;
b1b2de81	178
34e49164 C	179	Pretty_print_c.pp_param_gen
	180	(function x ->
	181	let str = Ast_c.str_of_info x in
	182	if not (List.mem str ["const";"volatile"])
faf9a90c	183	then pr str)
34e49164	184	(function _ -> pr " ")
b1b2de81 C	185	{Ast_c.p_register = (false,[]);
	186	p_namei = Some name';
	187	p_type = (({Ast_c.const = false; Ast_c.volatile = false},[]),ty)
	188	}
34e49164 C	189	\| _ -> failwith "function must have named parameters"
34e49164 C	190
faf9a90c	191	let make_exp = function
b1b2de81	192	({Ast_c.p_namei = Some name; p_type = ty}, comma_ii) ->
faf9a90c	193	let no_info = (None,Ast_c.NotTest) in
b1b2de81 C	194
	195	let name' = rewrap_prefix_name prefix name in
	196
faf9a90c	197	let exp =
b1b2de81	198	((Ast_c.Ident (name'),ref no_info),Ast_c.noii) in
faf9a90c C	199	(name,(Common.Left exp,comma_ii))
	200	\| _ -> failwith "bad parameter"
	201
0708f913	202	let print_extra_typedefs pr env =
faf9a90c C	203	let bigf =
	204	{ Visitor_c.default_visitor_c with
	205	Visitor_c.ktype = (fun (k, bigf) ty ->
	206	match ty with
0708f913	207	(_,((Ast_c.TypeName(_,_),_) as ty)) -> print_typedef pr ty
faf9a90c C	208	\| _ -> k ty) } in
	209	List.iter
	210	(function (_,vl) ->
	211	match vl with
	212	Ast_c.MetaIdVal(_) \| Ast_c.MetaFuncVal(_)
	213	\| Ast_c.MetaLocalFuncVal(_) -> ()
	214	\| Ast_c.MetaExprVal(exp) -> Visitor_c.vk_expr bigf exp
	215	\| Ast_c.MetaExprListVal(args) -> Visitor_c.vk_argument_list bigf args
	216	\| Ast_c.MetaParamVal(param) -> Visitor_c.vk_param bigf param
	217	\| Ast_c.MetaParamListVal(params) -> Visitor_c.vk_param_list bigf params
	218
	219	\| Ast_c.MetaTypeVal(ty) -> Visitor_c.vk_type bigf ty
113803cf	220	\| Ast_c.MetaInitVal(ty) -> Visitor_c.vk_ini bigf ty
faf9a90c C	221	\| Ast_c.MetaStmtVal(stm) -> Visitor_c.vk_statement bigf stm
	222	\| Ast_c.MetaPosVal _ \| Ast_c.MetaPosValList _
	223	\| Ast_c.MetaListlenVal _ -> ())
	224	env
	225
	226	let rename argids env =
b1b2de81 C	227	let argenv = List.map (function name ->
	228	let arg = Ast_c.str_of_name name in
	229	(arg,prefix^arg)
	230	) argids in
faf9a90c C	231	let lookup x = try List.assoc x argenv with Not_found -> x in
	232	let bigf =
	233	{ Visitor_c.default_visitor_c_s with
	234	Visitor_c.kexpr_s = (fun (k,bigf) e ->
	235	match e with
b1b2de81 C	236	((Ast_c.Ident (name), info), []) ->
	237
	238	(* pad: assert is_regular_ident ? *)
	239	let s = Ast_c.str_of_name name in
	240	let ii = Ast_c.info_of_name name in
faf9a90c	241	let new_name = lookup s in
b1b2de81 C	242	let new_id = Ast_c.RegularName (new_name, [rewrap_str new_name ii]) in
b1b2de81 C	243	((Ast_c.Ident (new_id), info), Ast_c.noii)
faf9a90c C	244	\| _ -> k e) } in
	245	List.map
	246	(function (x,vl) ->
	247	(x,
	248	match vl with
	249	Ast_c.MetaIdVal(_) \| Ast_c.MetaFuncVal(_)
	250	\| Ast_c.MetaLocalFuncVal(_) -> vl
	251	\| Ast_c.MetaExprVal(exp) ->
	252	Ast_c.MetaExprVal(Visitor_c.vk_expr_s bigf exp)
	253	\| Ast_c.MetaExprListVal(args) ->
	254	Ast_c.MetaExprListVal(Visitor_c.vk_arguments_s bigf args)
	255	\| Ast_c.MetaParamVal(param) ->
	256	Ast_c.MetaParamVal(Visitor_c.vk_param_s bigf param)
	257	\| Ast_c.MetaParamListVal(params) ->
	258	Ast_c.MetaParamListVal(Visitor_c.vk_params_s bigf params)
	259
	260	\| Ast_c.MetaTypeVal(ty) ->
	261	Ast_c.MetaTypeVal(Visitor_c.vk_type_s bigf ty)
113803cf C	262	\| Ast_c.MetaInitVal(ini) ->
113803cf C	263	Ast_c.MetaInitVal(Visitor_c.vk_ini_s bigf ini)
faf9a90c C	264	\| Ast_c.MetaStmtVal(stm) ->
	265	Ast_c.MetaStmtVal(Visitor_c.vk_statement_s bigf stm)
	266	\| Ast_c.MetaPosVal _ \| Ast_c.MetaPosValList _
	267	\| Ast_c.MetaListlenVal _ -> vl))
	268	env
	269
0708f913 C	270	let print_one_type pr env = function
	271	(Type_cocci.MetaType(name,keep,inherited)) as ty ->
	272	(try
	273	match List.assoc name env with
	274	Ast_c.MetaTypeVal ty ->
	275	Pretty_print_c.pp_type_gen
	276	(function x -> pr (Ast_c.str_of_info x))
	277	(function _ -> pr " ")
	278	ty
	279	\| _ -> failwith "impossible"
	280	with Not_found -> pr (Type_cocci.type2c ty))
	281	\| ty -> pr (Type_cocci.type2c ty)
	282
	283	let print_types pr env = function
faf9a90c	284	None -> ()
0708f913	285	\| Some [ty] -> print_one_type pr env ty
faf9a90c C	286	\| Some types ->
faf9a90c C	287	pr "{";
0708f913 C	288	Common.print_between (function _ -> pr ", ") (print_one_type pr env)
0708f913 C	289	types;
faf9a90c C	290	pr "}"
faf9a90c C	291
0708f913	292	let pp_meta_decl pr env decl =
faf9a90c C	293	let no_arity = function Ast.NONE -> () \| _ -> failwith "no arity allowed" in
	294	let pp_name (_,n) = pr n in
	295	match decl with
	296	Ast.MetaIdDecl(ar, name) ->
	297	no_arity ar; pr "identifier "; pp_name name; pr ";\n"
b1b2de81 C	298	\| Ast.MetaFreshIdDecl(name, None) ->
	299	pr "fresh identifier "; pp_name name; pr ";\n"
	300	\| Ast.MetaFreshIdDecl(name, Some x) ->
	301	pr "fresh identifier "; pp_name name; pr " = \""; pr x; pr "\";\n"
faf9a90c C	302	\| Ast.MetaTypeDecl(ar, name) ->
faf9a90c C	303	no_arity ar; pr "type "; pp_name name; pr ";\n"
113803cf C	304	\| Ast.MetaInitDecl(ar, name) ->
113803cf C	305	no_arity ar; pr "initialiser "; pp_name name; pr ";\n"
faf9a90c C	306	\| Ast.MetaListlenDecl(name) -> ()
	307	\| Ast.MetaParamDecl(ar, name) ->
	308	no_arity ar; pr "parameter "; pp_name name; pr ";\n"
	309	\| Ast.MetaParamListDecl(ar, name, None) ->
	310	no_arity ar; pr "parameter list "; pp_name name; pr ";\n"
	311	\| Ast.MetaParamListDecl(ar, name, Some len) ->
	312	no_arity ar; pr "parameter list "; pp_name name;
	313	pr "["; pp_name len; pr "]"; pr ";\n"
	314	\| Ast.MetaConstDecl(ar, name, types) ->
0708f913	315	no_arity ar; pr "constant "; print_types pr env types;
faf9a90c C	316	pp_name name; pr ";\n"
	317	\| Ast.MetaErrDecl(ar, name) ->
	318	no_arity ar; pr "error "; pp_name name; pr ";\n"
	319	\| Ast.MetaExpDecl(ar, name, None) ->
	320	no_arity ar; pr "expression "; pp_name name; pr ";\n"
	321	\| Ast.MetaExpDecl(ar, name, types) ->
0708f913	322	no_arity ar; print_types pr env types; pp_name name; pr ";\n"
faf9a90c C	323	\| Ast.MetaIdExpDecl(ar, name, types) ->
faf9a90c C	324	no_arity ar; pr "idexpression ";
0708f913	325	print_types pr env types; pp_name name; pr ";\n"
faf9a90c C	326	\| Ast.MetaLocalIdExpDecl(ar, name, types) ->
faf9a90c C	327	no_arity ar; pr "local idexpression ";
0708f913	328	print_types pr env types; pp_name name; pr ";\n"
faf9a90c C	329	\| Ast.MetaExpListDecl(ar, name, None) ->
	330	no_arity ar; pr "parameter list "; pp_name name; pr ";\n"
	331	\| Ast.MetaExpListDecl(ar, name, Some len) ->
	332	no_arity ar; pr "parameter list ";
	333	pp_name name; pr "["; pp_name len; pr "]"; pr ";\n"
	334	\| Ast.MetaStmDecl(ar, name) ->
	335	no_arity ar; pr "statement "; pp_name name; pr ";\n"
	336	\| Ast.MetaStmListDecl(ar, name) ->
	337	no_arity ar; pr "statement list "; pp_name name; pr ";\n"
	338	\| Ast.MetaFuncDecl(ar, name) ->
	339	no_arity ar; pr "function "; pp_name name; pr ";\n"
	340	\| Ast.MetaLocalFuncDecl(ar, name) ->
	341	no_arity ar; pr "local function "; pp_name name; pr ";\n"
	342	\| Ast.MetaPosDecl(ar, name) ->
	343	no_arity ar; pr "position "; pp_name name; pr ";\n"
	344	\| Ast.MetaDeclarerDecl(ar, name) ->
	345	no_arity ar; pr "declarer "; pp_name name; pr ";\n"
	346	\| Ast.MetaIteratorDecl(ar, name) ->
	347	no_arity ar; pr "iterator "; pp_name name; pr ";\n"
	348
0708f913	349	let print_metavariables pr local_metas paramst env header_req function_name =
34e49164 C	350	(if header_req
	351	then pr "@depends on header@\n"
	352	else pr "@@\n");
0708f913	353	pr (Printf.sprintf "position _p!=same_%s.p;\n" function_name);
faf9a90c	354	pr "identifier _f;\n";
faf9a90c	355	let rec loop = function
b1b2de81	356	[] \| [{Ast_c.p_type =(_,(Ast_c.BaseType(Ast_c.Void),_))},_] -> []
faf9a90c	357	\| ((first,_) as f)::rest ->
0708f913	358	print_metavar pr first; pr ";\n";
faf9a90c C	359	(make_exp f) :: loop rest in
faf9a90c C	360	let args = loop paramst in
0708f913 C	361	print_extra_typedefs pr env;
0708f913 C	362	List.iter (pp_meta_decl pr env) local_metas;
faf9a90c C	363	pr "@@\n\n";
faf9a90c C	364	args
34e49164 C	365
34e49164 C	366	(* ----------------------------------------------------------------------- *)
faf9a90c C	367	(* print_start/end *)
	368
	369	let print_start pr =
	370	pr "_f@_p(...) { <+...\n"
34e49164	371
faf9a90c C	372	let print_end pr =
faf9a90c C	373	pr "\n...+> }\n"
34e49164 C	374
	375	(* ----------------------------------------------------------------------- *)
	376	(* Print call to the defined function *)
	377
	378	let print_param_name pr = function
b1b2de81	379	{Ast_c.p_namei = Some name} -> pr (Ast_c.str_of_name name)
34e49164 C	380	\| _ -> failwith "function must have named parameters"
34e49164 C	381
485bce71	382	let pp_def_gen pr defn isexp =
b1b2de81 C	383	let {Ast_c.f_name = name; f_type = (_, (paramst, (b, iib))); } = defn in
b1b2de81 C	384	pr (Ast_c.str_of_name name); pr "(";
34e49164 C	385	(if b then failwith "not handling variable argument functions");
34e49164 C	386	(match paramst with
b1b2de81	387	[] \| [{Ast_c.p_type = (_,(Ast_c.BaseType(Ast_c.Void),_))},_] -> ()
34e49164 C	388	\| (first,_)::rest ->
	389	print_param_name pr first;
	390	List.iter (function (x,_) -> pr ", "; print_param_name pr x) rest);
	391	pr ")"; if not isexp then pr ";"
	392
	393	(* ----------------------------------------------------------------------- *)
	394	(* Entry point *)
	395
faf9a90c C	396	let pp_rule local_metas ast env srcfile =
	397	let (paramst,args_name) = get_paramst env in
	398	(* get rule information *)
	399	let (rule,printable) =
	400	match ast with
	401	Ast.CocciRule(_,_,[body],_,_) -> (* could extend to use attributes *)
	402	(body,
	403	match Ast.unwrap body with
	404	Ast.DECL(s) -> [[Ast.StatementTag s]]
	405	\| Ast.CODE(ss) -> [[Ast.StmtDotsTag ss]]
	406	\| _ -> error body "bad rule body")
	407	\| _ -> failwith "bad rule" in
	408	(* create the output file *)
	409	let outdir =
	410	match !Flag.make_hrule with
	411	Some outdir -> outdir
	412	\| None -> error rule "not possible" in
	413	let function_name = get_function_name rule env in
0708f913	414	let function_name_count =
faf9a90c	415	try
0708f913	416	let cell = List.assoc function_name !names in
faf9a90c C	417	let ct = !cell in
faf9a90c C	418	cell := ct + 1;
0708f913	419	function_name ^ (string_of_int ct)
faf9a90c	420	with Not_found ->
0708f913 C	421	let cell = ref 1 in
	422	names := (function_name,cell) :: !names;
	423	function_name in
	424	let outfile = outdir ^ "/" ^
	425	(if !Flag.hrule_per_file
	426	then Filename.chop_extension (Filename.basename srcfile)
	427	else function_name_count) in
	428	let escape_re = Str.regexp_string "/" in
	429	let dir = if !Flag.dir = "" then Filename.dirname srcfile else !Flag.dir in
	430	let outdirfile = Str.global_replace escape_re "_"dir in
	431	let outfile = outfile ^ outdirfile ^ ".cocci" in
	432	let saved_header_req =
	433	try let res = List.assoc outfile !started_files in Some res
	434	with Not_found -> None in
	435	current_outfile := outfile;
	436	Common.with_open_outfile_append outfile (fun (pr,chan) ->
	437	let header_req =
	438	match saved_header_req with
	439	Some x -> x
	440	\| None ->
	441	let res = print_header_rule pr srcfile in
	442	started_files := (outfile,res)::!started_files;
	443	res in
	444	print_check_rule pr function_name function_name_count header_req;
	445	let args =
	446	print_metavariables pr local_metas paramst env header_req
	447	function_name_count in
faf9a90c C	448	let (argids,args) = List.split args in
	449	let env = rename argids env in
	450	let env = (args_name,Ast_c.MetaExprListVal args)::env in
	451	print_start pr;
	452	(* for printing C tokens *)
	453	let pr_c info =
	454	match Ast_c.pinfo_of_info info with
	455	Ast_c.AbstractLineTok _ -> pr (Ast_c.str_of_info info)
	456	\| Ast_c.FakeTok (s,_) -> pr s
	457	\| _ ->
	458	Printf.printf "line: %s\n" (Common.dump info);
	459	error rule "not an abstract line" in
708f4980	460	let pr_space _ = pr " " in
faf9a90c	461	Unparse_cocci.pp_list_list_any
708f4980 C	462	(env, (fun s _ _ _ -> pr s), pr_c, pr_space, pr_space, pr,
708f4980 C	463	(fun _ _ -> ()), (function _ -> ()), (function _ -> ()))
faf9a90c C	464	true printable Unparse_cocci.InPlace;
	465	print_end pr;
	466	pr "\n")