-(* Copyright (C) 2006, 2007, 2008, 2009 Ecole des Mines de Nantes
+(* Yoann Padioleau
+ *
+ * Copyright (C) 2006, 2007, 2008, 2009 Ecole des Mines de Nantes
*
* This program is free software; you can redistribute it and/or
* modify it under the terms of the GNU General Public License (GPL)
* disable_go_type_annotation ?
*)
+(*****************************************************************************)
+(* Wrappers *)
+(*****************************************************************************)
+let pr2, pr2_once = Common.mk_pr2_wrappers Flag_parsing_c.verbose_visit
+
(*****************************************************************************)
(* Functions to visit the Ast, and now also the CFG nodes *)
(*****************************************************************************)
* and some of our analysis need only to specify an action for
* specific cases, such as the function call case, and recurse
* for the other cases.
- * Here is an simplification of our AST:
+ * Here is a simplification of our AST:
*
* type ctype =
* | Basetype of ...
* kfunction_call, kident, kpostfix hooks as one can just
* use pattern matching with kexpr to achieve the same effect.
*
+ * Note: when want to apply recursively, always apply the continuator
+ * on the toplevel expression, otherwise may miss some intermediate steps.
+ * Do
+ * match expr with
+ * | FunCall (e, es) -> ...
+ * k expr
+ * Or
+ * match expr with
+ * | FunCall (e, es) -> ...
+ * Visitor_c.vk_expr bigf e
+ * Not
+ * match expr with
+ * | FunCall (e, es) -> ...
+ * k e
+ *
+ *
*
*
*
* | other -> super#expr other
* end in analysis#expr
*
- * Problem is that you don't have control about what is generated
+ * The problem is that you don't have control about what is generated
* and in our case we sometimes dont want to visit too much. For instance
- * our visitor don't recuse on the type annotation of expressions
- * Ok, this could be worked around, but the pb remain, you
+ * our visitor don't recurse on the type annotation of expressions
+ * Ok, this could be worked around, but the pb remains, you
* don't have control and at some point you may want. In the same
* way we want to enforce a certain order in the visit (ok this is not good,
* but it's convenient) of ast elements. For instance first
kdecl: (declaration -> unit) * visitor_c -> declaration -> unit;
kdef: (definition -> unit) * visitor_c -> definition -> unit;
+ kname : (name -> unit) * visitor_c -> name -> unit;
+
kini: (initialiser -> unit) * visitor_c -> initialiser -> unit;
+ kfield: (field -> unit) * visitor_c -> field -> unit;
kcppdirective: (cpp_directive -> unit) * visitor_c -> cpp_directive -> unit;
kdefineval : (define_val -> unit) * visitor_c -> define_val -> unit;
kstatementseq: (statement_sequencable -> unit) * visitor_c -> statement_sequencable -> unit;
+
(* CFG *)
knode: (F.node -> unit) * visitor_c -> F.node -> unit;
(* AST *)
}
let default_visitor_c =
- { kexpr = (fun (k,_) e -> k e);
- kstatement = (fun (k,_) st -> k st);
- ktype = (fun (k,_) t -> k t);
- kdecl = (fun (k,_) d -> k d);
- kdef = (fun (k,_) d -> k d);
- kini = (fun (k,_) ie -> k ie);
- kinfo = (fun (k,_) ii -> k ii);
- knode = (fun (k,_) n -> k n);
- ktoplevel = (fun (k,_) p -> k p);
+ { kexpr = (fun (k,_) e -> k e);
+ kstatement = (fun (k,_) st -> k st);
+ ktype = (fun (k,_) t -> k t);
+ kdecl = (fun (k,_) d -> k d);
+ kdef = (fun (k,_) d -> k d);
+ kini = (fun (k,_) ie -> k ie);
+ kname = (fun (k,_) x -> k x);
+ kinfo = (fun (k,_) ii -> k ii);
+ knode = (fun (k,_) n -> k n);
+ ktoplevel = (fun (k,_) p -> k p);
kcppdirective = (fun (k,_) p -> k p);
- kdefineval = (fun (k,_) p -> k p);
- kstatementseq = (fun (k,_) p -> k p);
+ kdefineval = (fun (k,_) p -> k p);
+ kstatementseq = (fun (k,_) p -> k p);
+ kfield = (fun (k,_) p -> k p);
}
and k ((e,_typ), ii) =
iif ii;
match e with
- | Ident (s) -> ()
+ | Ident (name) -> vk_name bigf name
| Constant (c) -> ()
| FunCall (e, es) ->
exprf e;
| Binary (e1, op, e2) -> exprf e1; exprf e2;
| ArrayAccess (e1, e2) -> exprf e1; exprf e2;
- | RecordAccess (e, s) -> exprf e
- | RecordPtAccess (e, s) -> exprf e
+ | RecordAccess (e, name) -> exprf e; vk_name bigf name
+ | RecordPtAccess (e, name) -> exprf e; vk_name bigf name
| SizeOfExpr (e) -> exprf e
| SizeOfType (t) -> vk_type bigf t
iif is;
statxs +> List.iter (vk_statement_sequencable bigf);
- (* TODO, we will certainly have to then do a special visitor for
- * initializer
- *)
| Constructor (t, initxs) ->
vk_type bigf t;
initxs +> List.iter (fun (ini, ii) ->
in exprf expr
+(* ------------------------------------------------------------------------ *)
+and vk_name = fun bigf ident ->
+ let iif ii = vk_ii bigf ii in
+
+ let rec namef x = bigf.kname (k,bigf) x
+ and k id =
+ match id with
+ | RegularName (s, ii) -> iif ii
+ | CppConcatenatedName xs ->
+ xs +> List.iter (fun ((x,ii1), ii2) ->
+ iif ii2;
+ iif ii1;
+ );
+ | CppVariadicName (s, ii) -> iif ii
+ | CppIdentBuilder ((s,iis), xs) ->
+ iif iis;
+ xs +> List.iter (fun ((x,iix), iicomma) ->
+ iif iicomma;
+ iif iix;
+ )
+ in
+ namef ident
+(* ------------------------------------------------------------------------ *)
and vk_statement = fun bigf (st: Ast_c.statement) ->
let (unwrap_st, ii) = st in
iif ii;
match unwrap_st with
- | Labeled (Label (s, st)) -> statf st;
+ | Labeled (Label (name, st)) ->
+ vk_name bigf name;
+ statf st;
| Labeled (Case (e, st)) -> vk_expr bigf e; statf st;
| Labeled (CaseRange (e, e2, st)) ->
vk_expr bigf e; vk_expr bigf e2; statf st;
vk_expr bigf e; statf st;
| Iteration (DoWhile (st, e)) -> statf st; vk_expr bigf e;
| Iteration (For ((e1opt,i1), (e2opt,i2), (e3opt,i3), st)) ->
- statf (ExprStatement (e1opt),i1);
- statf (ExprStatement (e2opt),i2);
- statf (ExprStatement (e3opt),i3);
+ statf (mk_st (ExprStatement (e1opt)) i1);
+ statf (mk_st (ExprStatement (e2opt)) i2);
+ statf (mk_st (ExprStatement (e3opt)) i3);
statf st;
| Iteration (MacroIteration (s, es, st)) ->
vk_argument_list bigf es;
statf st;
- | Jump (Goto s) -> ()
+ | Jump (Goto name) -> vk_name bigf name
| Jump ((Continue|Break|Return)) -> ()
| Jump (ReturnExpr e) -> vk_expr bigf e;
| Jump (GotoComputed e) -> vk_expr bigf e;
)
| Enum (sopt, enumt) ->
- enumt +> List.iter (fun (((s, eopt),ii_s_eq), iicomma) ->
- iif ii_s_eq; iif iicomma;
- eopt +> do_option (vk_expr bigf)
- );
+ enumt +> List.iter (fun ((name, eopt), iicomma) ->
+ vk_name bigf name;
+ iif iicomma;
+ eopt +> Common.do_option (fun (info, e) ->
+ iif [info];
+ vk_expr bigf e
+ )
+ );
| StructUnion (sopt, _su, fields) ->
vk_struct_fields bigf fields
| EnumName s -> ()
(* dont go in _typ *)
- | TypeName (s, _typ) -> ()
+ | TypeName (name,_typ) ->
+ vk_name bigf name
| ParenType t -> typef t
| TypeOfExpr e -> vk_expr bigf e
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}) ->
+ | ({v_namei = var;
+ v_type = t;
+ v_storage = _sto;
+ v_attr = attrs}) ->
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)
- );
+ var +> Common.do_option (fun (name, iniopt) ->
+ vk_name bigf name;
+ iniopt +> Common.do_option (fun (info, ini) ->
+ iif [info];
+ vk_ini bigf ini;
+ );
+ )
and vk_ini = fun bigf ini ->
let iif ii = vk_ii bigf ii in
(* ------------------------------------------------------------------------ *)
and vk_struct_fields = fun bigf fields ->
+ fields +> List.iter (vk_struct_field bigf);
+
+and vk_struct_field = fun bigf field ->
let iif ii = vk_ii bigf ii in
- fields +> List.iter (fun (xfield, ii) ->
- iif ii;
- match xfield with
+ let f = bigf.kfield in
+ let rec k field =
+
+ match field with
| DeclarationField
(FieldDeclList (onefield_multivars, iiptvirg)) ->
vk_struct_fieldkinds bigf onefield_multivars;
iif iiptvirg;
- | EmptyField -> ()
- | MacroStructDeclTodo ->
- pr2_once "MacroStructDeclTodo";
- ()
+ | EmptyField info -> iif [info]
+ | MacroDeclField ((s, args),ii) ->
+ iif ii;
+ vk_argument_list bigf args;
| CppDirectiveStruct directive ->
vk_cpp_directive bigf directive
| IfdefStruct ifdef ->
vk_ifdef_directive bigf ifdef
+ in
+ f (k, bigf) field
+
- )
+
and vk_struct_fieldkinds = fun bigf onefield_multivars ->
let iif ii = vk_ii bigf ii in
onefield_multivars +> List.iter (fun (field, iicomma) ->
iif iicomma;
match field with
- | Simple (s, t), ii -> iif ii; vk_type bigf t;
- | BitField (sopt, t, expr), ii ->
- iif ii;
+ | Simple (nameopt, t) ->
+ Common.do_option (vk_name bigf) nameopt;
+ vk_type bigf t;
+ | BitField (nameopt, t, info, expr) ->
+ Common.do_option (vk_name bigf) nameopt;
+ vk_info bigf info;
vk_expr bigf expr;
vk_type bigf t
)
let f = bigf.kdef in
let rec k d =
match d with
- | {f_name = s;
+ | {f_name = name;
f_type = (returnt, (paramst, (b, iib)));
f_storage = sto;
f_body = statxs;
iif iib;
attrs +> List.iter (vk_attribute bigf);
vk_type bigf returnt;
+ vk_name bigf name;
paramst +> List.iter (fun (param,iicomma) ->
vk_param bigf param;
iif iicomma;
| F.Continue (st,((),ii)) -> iif ii
| F.Default (st,((),ii)) -> iif ii
| F.Return (st,((),ii)) -> iif ii
- | F.Goto (st, (s,ii)) -> iif ii
- | F.Label (st, (s,ii)) -> iif ii
+ | F.Goto (st, name, ((),ii)) -> vk_name bigf name; iif ii
+ | F.Label (st, name, ((),ii)) -> vk_name bigf name; iif ii
| F.DoHeader (st, info) -> infof info
-and vk_param = fun bigf (((b, s, t), ii_b_s)) ->
+and vk_param = fun bigf param ->
let iif ii = vk_ii bigf ii in
- iif ii_b_s;
- vk_type bigf t
+ let {p_namei = swrapopt; p_register = (b, iib); p_type=ft} = param in
+ swrapopt +> Common.do_option (vk_name bigf);
+ iif iib;
+ vk_type bigf ft
and vk_param_list = fun bigf ts ->
let iif ii = vk_ii bigf ii in
kdecl_s: (declaration inout * visitor_c_s) -> declaration inout;
kdef_s: (definition inout * visitor_c_s) -> definition inout;
+ kname_s: (name inout * visitor_c_s) -> name inout;
kini_s: (initialiser inout * visitor_c_s) -> initialiser inout;
ktype_s = (fun (k,_) t -> k t);
kdecl_s = (fun (k,_) d -> k d);
kdef_s = (fun (k,_) d -> k d);
+ kname_s = (fun (k,_) x -> k x);
kini_s = (fun (k,_) d -> k d);
ktoplevel_s = (fun (k,_) p -> k p);
knode_s = (fun (k,_) n -> k n);
let typ' = typ in
let e' =
match unwrap_e with
- | Ident (s) -> Ident (s)
+ | Ident (name) -> Ident (vk_name_s bigf name)
| Constant (c) -> Constant (c)
| FunCall (e, es) ->
FunCall (exprf e,
| Binary (e1, op, e2) -> Binary (exprf e1, op, exprf e2)
| ArrayAccess (e1, e2) -> ArrayAccess (exprf e1, exprf e2)
- | RecordAccess (e, s) -> RecordAccess (exprf e, s)
- | RecordPtAccess (e, s) -> RecordPtAccess (exprf e, s)
+ | RecordAccess (e, name) ->
+ RecordAccess (exprf e, vk_name_s bigf name)
+ | RecordPtAccess (e, name) ->
+ RecordPtAccess (exprf e, vk_name_s bigf name)
| SizeOfExpr (e) -> SizeOfExpr (exprf e)
| SizeOfType (t) -> SizeOfType (vk_type_s bigf t)
(e', typ'), (iif ii)
in exprf expr
+
and vk_argument_s bigf argument =
let iif ii = vk_ii_s bigf ii in
let rec do_action = function
| Right (ArgAction action) -> Right (ArgAction (do_action action))
)
+(* ------------------------------------------------------------------------ *)
+and vk_name_s = fun bigf ident ->
+ let iif ii = vk_ii_s bigf ii in
+ let rec namef x = bigf.kname_s (k,bigf) x
+ and k id =
+ (match id with
+ | RegularName (s,ii) -> RegularName (s, iif ii)
+ | CppConcatenatedName xs ->
+ CppConcatenatedName (xs +> List.map (fun ((x,ii1), ii2) ->
+ (x, iif ii1), iif ii2
+ ))
+ | CppVariadicName (s, ii) -> CppVariadicName (s, iif ii)
+ | CppIdentBuilder ((s,iis), xs) ->
+ CppIdentBuilder ((s, iif iis),
+ xs +> List.map (fun ((x,iix), iicomma) ->
+ ((x, iif iix), iif iicomma)))
+ )
+ in
+ namef ident
+
+(* ------------------------------------------------------------------------ *)
let (unwrap_st, ii) = st in
let st' =
match unwrap_st with
- | Labeled (Label (s, st)) ->
- Labeled (Label (s, statf st))
+ | Labeled (Label (name, st)) ->
+ Labeled (Label (vk_name_s bigf name, statf st))
| Labeled (Case (e, st)) ->
Labeled (Case ((vk_expr_s bigf) e , statf st))
| Labeled (CaseRange (e, e2, st)) ->
| Iteration (DoWhile (st, e)) ->
Iteration (DoWhile (statf st, (vk_expr_s bigf) e))
| Iteration (For ((e1opt,i1), (e2opt,i2), (e3opt,i3), st)) ->
- let e1opt' = statf (ExprStatement (e1opt),i1) in
- let e2opt' = statf (ExprStatement (e2opt),i2) in
- let e3opt' = statf (ExprStatement (e3opt),i3) in
- (match (e1opt', e2opt', e3opt') with
- | ((ExprStatement x1,i1), (ExprStatement x2,i2), ((ExprStatement x3,i3))) ->
- Iteration (For ((x1,i1), (x2,i2), (x3,i3), statf st))
+ let e1opt' = statf (mk_st (ExprStatement (e1opt)) i1) in
+ let e2opt' = statf (mk_st (ExprStatement (e2opt)) i2) in
+ let e3opt' = statf (mk_st (ExprStatement (e3opt)) i3) in
+
+ let e1' = Ast_c.unwrap_st e1opt' in
+ let e2' = Ast_c.unwrap_st e2opt' in
+ let e3' = Ast_c.unwrap_st e3opt' in
+ let i1' = Ast_c.get_ii_st_take_care e1opt' in
+ let i2' = Ast_c.get_ii_st_take_care e2opt' in
+ let i3' = Ast_c.get_ii_st_take_care e3opt' in
+
+ (match (e1', e2', e3') with
+ | ((ExprStatement x1), (ExprStatement x2), ((ExprStatement x3))) ->
+ Iteration (For ((x1,i1'), (x2,i2'), (x3,i3'), statf st))
+
| x -> failwith "cant be here if iterator keep ExprStatement as is"
)
))
- | Jump (Goto s) -> Jump (Goto s)
+ | Jump (Goto name) -> Jump (Goto (vk_name_s bigf name))
| Jump (((Continue|Break|Return) as x)) -> Jump (x)
| Jump (ReturnExpr e) -> Jump (ReturnExpr ((vk_expr_s bigf) e))
| Jump (GotoComputed e) -> Jump (GotoComputed (vk_expr_s bigf e));
| IfdefStmt2 (ifdef, xxs) ->
let ifdef' = List.map (vk_ifdef_directive_s bigf) ifdef in
let xxs' = xxs +> List.map (fun xs ->
- xs +> List.map (vk_statement_sequencable_s bigf)
+ xs +> vk_statement_sequencable_list_s bigf
)
in
IfdefStmt2(ifdef', xxs')
+(* todo? a visitor for qualifier *)
and vk_type_s = fun bigf t ->
let rec typef t = bigf.ktype_s (k,bigf) t
and iif ii = vk_ii_s bigf ii
let (unwrap_q, iiq) = q in
(* strip_info_visitor needs iiq to be processed before iit *)
let iif_iiq = iif iiq in
- let q' = unwrap_q in (* todo? a visitor for qualifier *)
+ let q' = unwrap_q in
let (unwrap_t, iit) = t in
let t' =
match unwrap_t with
| Enum (sopt, enumt) ->
Enum (sopt,
- enumt +> List.map (fun (((s, eopt),ii_s_eq), iicomma) ->
- ((s, fmap (vk_expr_s bigf) eopt), iif ii_s_eq),
- iif iicomma
+ enumt +> List.map (fun ((name, eopt), iicomma) ->
+
+ ((vk_name_s bigf name,
+ eopt +> Common.fmap (fun (info, e) ->
+ vk_info_s bigf info,
+ vk_expr_s bigf e
+ )),
+ iif iicomma)
+ )
)
- )
| StructUnion (sopt, su, fields) ->
StructUnion (sopt, su, vk_struct_fields_s bigf fields)
| StructUnionName (s, structunion) -> StructUnionName (s, structunion)
| EnumName s -> EnumName s
- | TypeName (s, typ) -> TypeName (s, typ)
+ | TypeName (name, typ) -> TypeName (vk_name_s bigf name, typ)
| ParenType t -> ParenType (typef t)
| TypeOfExpr e -> TypeOfExpr (vk_expr_s bigf e)
iif ii)
- and aux ({v_namei = var; v_type = t;
- v_storage = sto; v_local= local; v_attr = attrs}, iicomma) =
+ and aux ({v_namei = var;
+ v_type = t;
+ v_storage = sto;
+ v_local= local;
+ v_attr = attrs}, iicomma) =
{v_namei =
- (var +> map_option (fun ((s, ini), ii_s_ini) ->
- (s, ini +> map_option (fun init -> vk_ini_s bigf init)),
- iif ii_s_ini
- )
- );
+ (var +> map_option (fun (name, iniopt) ->
+ vk_name_s bigf name,
+ iniopt +> map_option (fun (info, init) ->
+ vk_info_s bigf info,
+ vk_ini_s bigf init
+ )));
v_type = vk_type_s bigf t;
v_storage = sto;
v_local = local;
onefield_multivars +> List.map (fun (field, iicomma) ->
(match field with
- | Simple (s, t), iis -> Simple (s, vk_type_s bigf t), iif iis
- | BitField (sopt, t, expr), iis ->
- BitField (sopt, vk_type_s bigf t, vk_expr_s bigf expr),
- iif iis
+ | Simple (nameopt, t) ->
+ Simple (Common.map_option (vk_name_s bigf) nameopt,
+ vk_type_s bigf t)
+ | BitField (nameopt, t, info, expr) ->
+ BitField (Common.map_option (vk_name_s bigf) nameopt,
+ vk_type_s bigf t,
+ vk_info_s bigf info,
+ vk_expr_s bigf expr)
), iif iicomma
)
let iif ii = vk_ii_s bigf ii in
- fields +> List.map (fun (xfield, iiptvirg) ->
-
- (match xfield with
+ fields +> List.map (fun (field) ->
+ (match field with
| (DeclarationField (FieldDeclList (onefield_multivars, iiptvirg))) ->
DeclarationField
(FieldDeclList
(vk_struct_fieldkinds_s bigf onefield_multivars, iif iiptvirg))
- | EmptyField -> EmptyField
- | MacroStructDeclTodo ->
- pr2_once "MacroStructDeclTodo";
- MacroStructDeclTodo
+ | EmptyField info -> EmptyField (vk_info_s bigf info)
+ | MacroDeclField ((s, args),ii) ->
+ MacroDeclField
+ ((s,
+ args +> List.map (fun (e,ii) -> vk_argument_s bigf e, iif ii)
+ ),
+ iif ii)
| CppDirectiveStruct directive ->
CppDirectiveStruct (vk_cpp_directive_s bigf directive)
| IfdefStruct ifdef ->
IfdefStruct (vk_ifdef_directive_s bigf ifdef)
- ), iif iiptvirg
+ )
)
let iif ii = vk_ii_s bigf ii in
let rec k d =
match d with
- | {f_name = s;
+ | {f_name = name;
f_type = (returnt, (paramst, (b, iib)));
f_storage = sto;
f_body = statxs;
f_old_c_style = oldstyle;
}, ii
->
- {f_name = s;
+ {f_name = vk_name_s bigf name;
f_type =
(vk_type_s bigf returnt,
(paramst +> List.map (fun (param, iicomma) ->
i_content = copt;
}
->
- assert (copt = None);
+ assert (copt =*= None);
F.Include {i_include = (s, iif ii);
i_rel_pos = h_rel_pos;
i_is_in_ifdef = b;
| F.Continue (st,((),ii)) -> F.Continue (st,((),iif ii))
| F.Default (st,((),ii)) -> F.Default (st,((),iif ii))
| F.Return (st,((),ii)) -> F.Return (st,((),iif ii))
- | F.Goto (st, (s,ii)) -> F.Goto (st, (s,iif ii))
- | F.Label (st, (s,ii)) -> F.Label (st, (s,iif ii))
+ | F.Goto (st, name, ((),ii)) ->
+ F.Goto (st, vk_name_s bigf name, ((),iif ii))
+ | F.Label (st, name, ((),ii)) ->
+ F.Label (st, vk_name_s bigf name, ((),iif ii))
| F.EndStatement iopt -> F.EndStatement (map_option infof iopt)
| F.DoHeader (st, info) -> F.DoHeader (st, infof info)
| F.Else info -> F.Else (infof info)
nodef node
(* ------------------------------------------------------------------------ *)
-and vk_param_s = fun bigf ((b, s, t), ii_b_s) ->
+and vk_param_s = fun bigf param ->
let iif ii = vk_ii_s bigf ii in
- ((b, s, vk_type_s bigf t), iif ii_b_s)
+ let {p_namei = swrapopt; p_register = (b, iib); p_type=ft} = param in
+ { p_namei = swrapopt +> Common.map_option (vk_name_s bigf);
+ p_register = (b, iif iib);
+ p_type = vk_type_s bigf ft;
+ }
let vk_args_splitted_s = fun bigf args_splitted ->
let iif ii = vk_ii_s bigf ii in
HCoop / bpt / coccinelle.git / blobdiff