+(*
+ * Copyright (C) 2010, University of Copenhagen DIKU and INRIA.
+ * Copyright (C) 2006, 2007 Julia Lawall
+ *
+ * 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.
+ *
+ * This file was part of Coccinelle.
+ *)
+
module Ast = Ast_cocci
module V = Visitor_ast
[] 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.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) ->
+ Ast.BEFORE(any_list_list,_) | Ast.AFTER(any_list_list,_) ->
do_any_list_list r any_list_list
- | Ast.BEFOREAFTER(ba,aa) ->
+ | Ast.BEFOREAFTER(ba,aa,_) ->
bind (do_any_list_list r ba) (do_any_list_list r aa)
| Ast.NOTHING -> [])
- | Ast.PLUS -> [] in
+ | Ast.PLUS _ -> [] in
let expression r k e =
bind (k e)
(match Ast.unwrap e 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_mcode nm,Ast.get_mcodekind nm) with
+ ((_,"ARGS"), Ast.PLUS _) ->
(match Ast.unwrap fn with
Ast.Ident(id) ->
(match Ast.unwrap id with
let names =
(V.combiner bind option_default
mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing
+ donothing 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.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(s,_),_) ->
+ (Ast_c.TypeName(name,_),_) ->
+ let s = Ast_c.str_of_name name in
let typedefs =
try List.assoc !current_outfile !typedefs
with Not_found ->
| 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
- ((_,Some param,(_,(Ast_c.Pointer(_,(Ast_c.BaseType(Ast_c.Void),_)),_))),_)
+ | {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
- | (((_,Some param,(_,ty)),il) : Ast_c.parameterType) ->
- let il =
- match List.rev il with
- name::rest -> (rewrap_str (prefix^param) name) :: rest
- | _ -> failwith "no name" in
+ | ({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 " ")
- ((false,Some param,
- (({Ast_c.const = false; Ast_c.volatile = false},[]),ty)),
- il)
+ {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
- (((_,Some name,ty),param_ii),comma_ii) ->
+ ({Ast_c.p_namei = Some name; p_type = ty}, comma_ii) ->
let no_info = (None,Ast_c.NotTest) in
- let nm = prefix^name in
+
+ let name' = rewrap_prefix_name prefix name in
+
let exp =
- ((Ast_c.Ident nm,ref no_info),
- [rewrap_str nm (List.hd(List.rev param_ii))]) in
+ ((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 ->
+ Visitor_c.ktype = (fun (k, bigf) ty ->
match ty with
(_,((Ast_c.TypeName(_,_),_) as ty)) -> print_typedef pr ty
| _ -> k ty) } in
match vl with
Ast_c.MetaIdVal(_) | Ast_c.MetaFuncVal(_)
| Ast_c.MetaLocalFuncVal(_) -> ()
- | Ast_c.MetaExprVal(exp) -> Visitor_c.vk_expr bigf exp
+ | 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.MetaDeclVal(decl) -> Visitor_c.vk_decl bigf decl
+ | Ast_c.MetaFieldVal(field) -> Visitor_c.vk_struct_field bigf field
+ | Ast_c.MetaFieldListVal(fields) -> Visitor_c.vk_struct_fields bigf fields
| 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 arg -> (arg,prefix^arg)) argids in
+ 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 ->
+ Visitor_c.kexpr_s = (fun (k,bigf) e ->
match e with
- ((Ast_c.Ident s, info), [ii]) ->
+ ((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
- ((Ast_c.Ident new_name, info), [rewrap_str new_name ii])
+ 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) ->
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.MetaExprVal(exp,c) ->
+ Ast_c.MetaExprVal(Visitor_c.vk_expr_s bigf exp,c)
| Ast_c.MetaExprListVal(args) ->
Ast_c.MetaExprListVal(Visitor_c.vk_arguments_s bigf args)
| Ast_c.MetaParamVal(param) ->
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.MetaDeclVal(stm) ->
+ Ast_c.MetaDeclVal(Visitor_c.vk_decl_s bigf stm)
+ | Ast_c.MetaFieldVal(stm) ->
+ Ast_c.MetaFieldVal(Visitor_c.vk_struct_field_s bigf stm)
+ | Ast_c.MetaFieldListVal(stm) ->
+ Ast_c.MetaFieldListVal(Visitor_c.vk_struct_fields_s bigf stm)
| Ast_c.MetaStmtVal(stm) ->
Ast_c.MetaStmtVal(Visitor_c.vk_statement_s bigf stm)
| Ast_c.MetaPosVal _ | Ast_c.MetaPosValList _
(Type_cocci.MetaType(name,keep,inherited)) as ty ->
(try
match List.assoc name env with
- Ast_c.MetaTypeVal ty ->
+ Ast_c.MetaTypeVal ty ->
Pretty_print_c.pp_type_gen
(function x -> pr (Ast_c.str_of_info x))
(function _ -> pr " ")
types;
pr "}"
+let pp_len pr len =
+ let pp_name (_,n) = pr n in
+ match len with
+ Ast.AnyLen -> ()
+ | Ast.MetaLen len -> pr "["; pp_name len; pr "]"
+ | Ast.CstLen len -> pr "["; pr (string_of_int len); 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) ->
+ Ast.MetaMetaDecl(ar, name) ->
+ (* ignore virtual *)
+ no_arity ar; pr "metavariable "; pp_name name; pr ";\n"
+ | Ast.MetaIdDecl(ar, name) ->
+ (* ignore virtual *)
no_arity ar; pr "identifier "; pp_name name; pr ";\n"
- | Ast.MetaFreshIdDecl(ar, name) ->
- no_arity ar; pr "fresh identifier "; pp_name name; pr ";\n"
+ | Ast.MetaFreshIdDecl(name, Ast.NoVal) ->
+ pr "fresh identifier "; pp_name name; pr ";\n"
+ | Ast.MetaFreshIdDecl(name, Ast.StringSeed x) ->
+ pr "fresh identifier "; pp_name name; pr " = \""; pr x; pr "\";\n"
+ | Ast.MetaFreshIdDecl(name, Ast.ListSeed x) ->
+ failwith "unparse_hrule: not supported"
| Ast.MetaTypeDecl(ar, name) ->
no_arity ar; pr "type "; pp_name name; pr ";\n"
| Ast.MetaInitDecl(ar, name) ->
| 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.MetaParamListDecl(ar, name, len) ->
+ no_arity ar; pr "parameter list "; pp_name name; pp_len pr len; pr ";\n"
| Ast.MetaConstDecl(ar, name, types) ->
no_arity ar; pr "constant "; 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.MetaExpListDecl(ar, name, len) ->
+ no_arity ar; pr "parameter list "; pp_name name; pp_len pr len; pr ";\n"
+ | Ast.MetaDeclDecl(ar, name) ->
+ no_arity ar; pr "declaration "; pp_name name; pr ";\n"
+ | Ast.MetaFieldDecl(ar, name) ->
+ no_arity ar; pr "field "; pp_name name; pr ";\n"
+ | Ast.MetaFieldListDecl(ar, name, len) ->
+ no_arity ar; pr "field list "; pp_name name; pp_len pr len; pr ";\n"
| Ast.MetaStmDecl(ar, name) ->
no_arity ar; pr "statement "; pp_name name; pr ";\n"
| Ast.MetaStmListDecl(ar, name) ->
pr (Printf.sprintf "position _p!=same_%s.p;\n" function_name);
pr "identifier _f;\n";
let rec loop = function
- [] | [(((_,_,(_,(Ast_c.BaseType(Ast_c.Void),_))),_),_)] -> []
+ [] | [{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
(* Print call to the defined function *)
let print_param_name pr = function
- ((_,Some param,_),_) -> pr param
+ {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 = s; f_type = (_, (paramst, (b, iib))); } = defn in
- pr s; pr "(";
+ 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.BaseType(Ast_c.Void),_))),_),_)] -> ()
+ [] | [{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);
| _ ->
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, pr, pr_c, (function _ -> pr " "),
- (function _ -> ()), (function _ -> ()))
+ ([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")
HCoop / bpt / coccinelle.git / blobdiff