(*
+ * Copyright 2012, INRIA
+ * Julia Lawall, Gilles Muller
+ * Copyright 2010-2011, INRIA, University of Copenhagen
+ * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
* This file is part of Coccinelle.
let astfvident recursor k i =
bind (k i)
(match Ast.unwrap i with
- Ast.MetaId(name,_,_,_) | Ast.MetaFunc(name,_,_,_)
- | Ast.MetaLocalFunc(name,_,_,_) -> [metaid name]
+ Ast.MetaId(name,idconstraint,_,_) | Ast.MetaFunc(name,idconstraint,_,_)
+ | Ast.MetaLocalFunc(name,idconstraint,_,_) ->
+ let metas =
+ if include_constraints
+ then
+ match idconstraint with
+ Ast.IdNegIdSet (_,metas) -> metas
+ | _ -> []
+ else [] in
+ bind (List.rev metas) [metaid name]
+ | Ast.DisjId(ids) -> bind_disj (List.map k ids)
| _ -> option_default) in
let rec type_collect res = function
TC.ConstVol(_,ty) | TC.Pointer(ty) | TC.FunctionPointer(ty)
| TC.Array(ty) -> type_collect res ty
- | TC.MetaType(tyname,_,_) -> bind [tyname] res
+ | TC.EnumName(TC.MV(tyname,_,_)) ->
+ bind [tyname] res
+ | TC.StructUnionName(_,TC.MV(tyname,_,_)) ->
+ bind [tyname] res
+ | TC.MetaType(tyname,_,_) ->
+ bind [tyname] res
| TC.SignedT(_,Some ty) -> type_collect res ty
| ty -> res in
let astfvexpr recursor k e =
bind (k e)
(match Ast.unwrap e with
- Ast.MetaExpr(name,_,_,Some type_list,_,_) ->
+ Ast.MetaExpr(name,constraints,_,Some type_list,_,_) ->
let types = List.fold_left type_collect option_default type_list in
- bind [metaid name] types
- | Ast.MetaErr(name,_,_,_) | Ast.MetaExpr(name,_,_,_,_,_) -> [metaid name]
- | Ast.MetaExprList(name,None,_,_) -> [metaid name]
- | Ast.MetaExprList(name,Some (lenname,_,_),_,_) ->
+ let extra =
+ if include_constraints
+ then
+ match constraints with
+ Ast.SubExpCstrt l -> l
+ | _ -> []
+ else [] in
+ bind extra (bind [metaid name] types)
+ | Ast.MetaErr(name,constraints,_,_)
+ | Ast.MetaExpr(name,constraints,_,_,_,_) ->
+ let extra =
+ if include_constraints
+ then
+ match constraints with
+ Ast.SubExpCstrt l -> l
+ | _ -> []
+ else [] in
+ bind extra [metaid name]
+ | Ast.MetaExprList(name,Ast.MetaListLen (lenname,_,_),_,_) ->
[metaid name;metaid lenname]
+ | Ast.MetaExprList(name,_,_,_) -> [metaid name]
| Ast.DisjExpr(exps) -> bind_disj (List.map k exps)
| _ -> option_default) in
let astfvdecls recursor k d =
bind (k d)
(match Ast.unwrap d with
- Ast.DisjDecl(decls) -> bind_disj (List.map k decls)
+ Ast.MetaDecl(name,_,_) | Ast.MetaField(name,_,_) -> [metaid name]
+ | Ast.MetaFieldList(name,Ast.MetaListLen(lenname,_,_),_,_) ->
+ [metaid name;metaid lenname]
+ | Ast.MetaFieldList(name,_,_,_) ->
+ [metaid name]
+ | Ast.DisjDecl(decls) -> bind_disj (List.map k decls)
| _ -> option_default) in
let astfvfullType recursor k ty =
bind (k ty)
(match Ast.unwrap ty with
Ast.MetaInit(name,_,_) -> [metaid name]
+ | Ast.MetaInitList(name,Ast.MetaListLen(lenname,_,_),_,_) ->
+ [metaid name;metaid lenname]
+ | Ast.MetaInitList(name,_,_,_) -> [metaid name]
| _ -> option_default) in
let astfvparam recursor k p =
bind (k p)
(match Ast.unwrap p with
Ast.MetaParam(name,_,_) -> [metaid name]
- | Ast.MetaParamList(name,None,_,_) -> [metaid name]
- | Ast.MetaParamList(name,Some(lenname,_,_),_,_) ->
+ | Ast.MetaParamList(name,Ast.MetaListLen(lenname,_,_),_,_) ->
[metaid name;metaid lenname]
+ | Ast.MetaParamList(name,_,_,_) -> [metaid name]
| _ -> option_default) in
let astfvrule_elem recursor k re =
let mcode r mc =
if include_constraints
then
- match Ast.get_pos_var mc with
- Ast.MetaPos(name,constraints,_,_,_) -> (metaid name)::constraints
- | _ -> option_default
+ List.concat
+ (List.map
+ (function Ast.MetaPos(name,constraints,_,_,_) ->
+ (metaid name)::constraints)
+ (Ast.get_pos_var mc))
else option_default in
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
astfvident astfvexpr astfvfullType astfvtypeC astfvinit astfvparam
astfvdecls astfvrule_elem astfvstatement donothing donothing donothing_a
let astfvident recursor k i =
bind (k i)
(match Ast.unwrap i with
- Ast.MetaId(name,_,TC.Saved,_) | Ast.MetaFunc(name,_,TC.Saved,_)
+ Ast.MetaId(name,_,TC.Saved,_)
+ | Ast.MetaFunc(name,_,TC.Saved,_)
| Ast.MetaLocalFunc(name,_,TC.Saved,_) -> [metaid name]
| _ -> option_default) in
let rec type_collect res = function
TC.ConstVol(_,ty) | TC.Pointer(ty) | TC.FunctionPointer(ty)
| TC.Array(ty) -> type_collect res ty
- | TC.MetaType(tyname,TC.Saved,_) -> bind [tyname] res
+ | TC.EnumName(TC.MV(tyname,TC.Saved,_)) ->
+ bind [tyname] res
+ | TC.StructUnionName(_,TC.MV(tyname,TC.Saved,_)) ->
+ bind [tyname] res
+ | TC.MetaType(tyname,TC.Saved,_) ->
+ bind [tyname] res
| TC.SignedT(_,Some ty) -> type_collect res ty
| ty -> res in
bind (k e)
(match Ast.unwrap e with
Ast.MetaErr(name,_,TC.Saved,_) | Ast.MetaExpr(name,_,TC.Saved,_,_,_)
- | Ast.MetaExprList(name,None,TC.Saved,_) -> [metaid name]
- | Ast.MetaExprList(name,Some (lenname,ls,_),ns,_) ->
+ -> [metaid name]
+ | Ast.MetaExprList(name,Ast.MetaListLen (lenname,ls,_),ns,_) ->
let namesaved =
match ns with TC.Saved -> [metaid name] | _ -> [] in
let lensaved =
match ls with TC.Saved -> [metaid lenname] | _ -> [] in
lensaved @ namesaved
+ | Ast.MetaExprList(name,_,TC.Saved,_) -> [metaid name]
| _ -> option_default) in
bind tymetas vars in
bind (k ty)
(match Ast.unwrap ty with
Ast.MetaInit(name,TC.Saved,_) -> [metaid name]
+ | Ast.MetaInitList(name,Ast.MetaListLen (lenname,ls,_),ns,_) ->
+ let namesaved =
+ match ns with TC.Saved -> [metaid name] | _ -> [] in
+ let lensaved =
+ match ls with TC.Saved -> [metaid lenname] | _ -> [] in
+ lensaved @ namesaved
| _ -> option_default) in
let astfvparam recursor k p =
bind (k p)
(match Ast.unwrap p with
- Ast.MetaParam(name,TC.Saved,_)
- | Ast.MetaParamList(name,None,_,_) -> [metaid name]
- | Ast.MetaParamList(name,Some (lenname,ls,_),ns,_) ->
+ Ast.MetaParam(name,TC.Saved,_) -> [metaid name]
+ | Ast.MetaParamList(name,Ast.MetaListLen (lenname,ls,_),ns,_) ->
+ let namesaved =
+ match ns with TC.Saved -> [metaid name] | _ -> [] in
+ let lensaved =
+ match ls with TC.Saved -> [metaid lenname] | _ -> [] in
+ lensaved @ namesaved
+ | Ast.MetaParamList(name,_,TC.Saved,_) -> [metaid name]
+ | _ -> option_default) in
+
+ let astfvdecls recursor k d =
+ bind (k d)
+ (match Ast.unwrap d with
+ Ast.MetaDecl(name,TC.Saved,_) | Ast.MetaField(name,TC.Saved,_) ->
+ [metaid name]
+ | Ast.MetaFieldList(name,Ast.MetaListLen (lenname,ls,_),ns,_) ->
let namesaved =
match ns with TC.Saved -> [metaid name] | _ -> [] in
let lensaved =
match ls with TC.Saved -> [metaid lenname] | _ -> [] in
lensaved @ namesaved
+ | Ast.MetaFieldList(name,_,TC.Saved,_) -> [metaid name]
| _ -> option_default) in
let astfvrule_elem recursor k re =
| _ -> option_default)) in
let mcode r e =
- match Ast.get_pos_var e with
- Ast.MetaPos(name,_,_,TC.Saved,_) -> [metaid name]
- | _ -> option_default in
+ List.fold_left
+ (function acc ->
+ function
+ Ast.MetaPos(name,_,_,TC.Saved,_) -> (metaid name) :: acc
+ | _ -> acc)
+ option_default (Ast.get_pos_var e) in
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
astfvident astfvexpr donothing astfvtypeC astfvinit astfvparam
- donothing astfvrule_elem donothing donothing donothing donothing
+ astfvdecls astfvrule_elem donothing donothing donothing donothing
(* ---------------------------------------------------------------- *)
(List.map (function l -> List.fold_left (@) [] (List.map astfvs l))
anythings) in
match mck with
- Ast.MINUS(_,_,_,anythings) -> process_anything_list_list anythings
+ Ast.MINUS(_,_,_,replacement) ->
+ (match replacement with
+ Ast.REPLACEMENT(anythings,_) -> process_anything_list_list anythings
+ | Ast.NOREPLACEMENT -> [])
| Ast.CONTEXT(_,befaft) ->
(match befaft with
Ast.BEFORE(ll,_) -> process_anything_list_list ll
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 donothing donothing donothing donothing donothing
donothing astfvrule_elem astfvstatement donothing donothing donothing
(check_unitary name inherited,inherited) in
let mcode mc =
- match Ast.get_pos_var mc with
- Ast.MetaPos(name,constraints,per,unitary,inherited) ->
- let (unitary,inherited) = classify name in
- Ast.set_pos_var (Ast.MetaPos(name,constraints,per,unitary,inherited))
- mc
- | _ -> mc in
+ let p =
+ List.map
+ (function Ast.MetaPos(name,constraints,per,unitary,inherited) ->
+ let (unitary,inherited) = classify name in
+ Ast.MetaPos(name,constraints,per,unitary,inherited))
+ (Ast.get_pos_var mc) in
+ Ast.set_pos_var p mc in
let ident r k e =
let e = k e in
match Ast.unwrap e with
Ast.MetaId(name,constraints,_,_) ->
let (unitary,inherited) = classify name in
- Ast.rewrap e (Ast.MetaId(name,constraints,unitary,inherited))
+ Ast.rewrap e
+ (Ast.MetaId(name,constraints,unitary,inherited))
| Ast.MetaFunc(name,constraints,_,_) ->
let (unitary,inherited) = classify name in
Ast.rewrap e (Ast.MetaFunc(name,constraints,unitary,inherited))
| TC.Pointer(ty) -> TC.Pointer(type_infos ty)
| TC.FunctionPointer(ty) -> TC.FunctionPointer(type_infos ty)
| TC.Array(ty) -> TC.Array(type_infos ty)
+ | TC.EnumName(TC.MV(name,_,_)) ->
+ let (unitary,inherited) = classify (name,(),(),[]) in
+ TC.EnumName(TC.MV(name,unitary,inherited))
+ | TC.StructUnionName(su,TC.MV(name,_,_)) ->
+ let (unitary,inherited) = classify (name,(),(),[]) in
+ TC.StructUnionName(su,TC.MV(name,unitary,inherited))
| TC.MetaType(name,_,_) ->
- let (unitary,inherited) = classify (name,(),(),Ast.NoMetaPos) in
+ let (unitary,inherited) = classify (name,(),(),[]) in
Type_cocci.MetaType(name,unitary,inherited)
| TC.SignedT(sgn,Some ty) -> TC.SignedT(sgn,Some (type_infos ty))
| ty -> ty in
let (unitary,inherited) = classify name in
let ty = get_option (List.map type_infos) ty in
Ast.rewrap e (Ast.MetaExpr(name,constraints,unitary,ty,form,inherited))
- | Ast.MetaExprList(name,None,_,_) ->
- (* lenname should have the same properties of being unitary or
- inherited as name *)
- let (unitary,inherited) = classify name in
- Ast.rewrap e (Ast.MetaExprList(name,None,unitary,inherited))
- | Ast.MetaExprList(name,Some(lenname,_,_),_,_) ->
+ | Ast.MetaExprList(name,Ast.MetaListLen(lenname,_,_),_,_) ->
(* lenname should have the same properties of being unitary or
inherited as name *)
let (unitary,inherited) = classify name in
let (lenunitary,leninherited) = classify lenname in
Ast.rewrap e
(Ast.MetaExprList
- (name,Some(lenname,lenunitary,leninherited),unitary,inherited))
+ (name,
+ Ast.MetaListLen(lenname,lenunitary,leninherited),
+ unitary,inherited))
+ | Ast.MetaExprList(name,lenname,_,_) ->
+ (* lenname should have the same properties of being unitary or
+ inherited as name *)
+ let (unitary,inherited) = classify name in
+ Ast.rewrap e (Ast.MetaExprList(name,lenname,unitary,inherited))
| _ -> e in
let typeC r k e =
Ast.MetaInit(name,_,_) ->
let (unitary,inherited) = classify name in
Ast.rewrap e (Ast.MetaInit(name,unitary,inherited))
+ | Ast.MetaInitList(name,Ast.MetaListLen (lenname,_,_),_,_) ->
+ let (unitary,inherited) = classify name in
+ let (lenunitary,leninherited) = classify lenname in
+ Ast.rewrap e
+ (Ast.MetaInitList
+ (name,Ast.MetaListLen(lenname,lenunitary,leninherited),
+ unitary,inherited))
+ | Ast.MetaInitList(name,lenname,_,_) ->
+ let (unitary,inherited) = classify name in
+ Ast.rewrap e (Ast.MetaInitList(name,lenname,unitary,inherited))
| _ -> e in
let param r k e =
Ast.MetaParam(name,_,_) ->
let (unitary,inherited) = classify name in
Ast.rewrap e (Ast.MetaParam(name,unitary,inherited))
- | Ast.MetaParamList(name,None,_,_) ->
- let (unitary,inherited) = classify name in
- Ast.rewrap e (Ast.MetaParamList(name,None,unitary,inherited))
- | Ast.MetaParamList(name,Some (lenname,_,_),_,_) ->
+ | Ast.MetaParamList(name,Ast.MetaListLen (lenname,_,_),_,_) ->
let (unitary,inherited) = classify name in
let (lenunitary,leninherited) = classify lenname in
Ast.rewrap e
(Ast.MetaParamList
- (name,Some (lenname,lenunitary,leninherited),unitary,inherited))
+ (name,Ast.MetaListLen(lenname,lenunitary,leninherited),
+ unitary,inherited))
+ | Ast.MetaParamList(name,lenname,_,_) ->
+ let (unitary,inherited) = classify name in
+ Ast.rewrap e (Ast.MetaParamList(name,lenname,unitary,inherited))
+ | _ -> e in
+
+ let decl r k e =
+ let e = k e in
+ match Ast.unwrap e with
+ Ast.MetaDecl(name,_,_) ->
+ let (unitary,inherited) = classify name in
+ Ast.rewrap e (Ast.MetaDecl(name,unitary,inherited))
+ | Ast.MetaField(name,_,_) ->
+ let (unitary,inherited) = classify name in
+ Ast.rewrap e (Ast.MetaField(name,unitary,inherited))
+ | Ast.MetaFieldList(name,Ast.MetaListLen (lenname,_,_),_,_) ->
+ let (unitary,inherited) = classify name in
+ let (lenunitary,leninherited) = classify lenname in
+ Ast.rewrap e
+ (Ast.MetaFieldList
+ (name,Ast.MetaListLen(lenname,lenunitary,leninherited),
+ unitary,inherited))
+ | Ast.MetaFieldList(name,lenname,_,_) ->
+ let (unitary,inherited) = classify name in
+ Ast.rewrap e (Ast.MetaFieldList(name,lenname,unitary,inherited))
| _ -> e in
let rule_elem r k e =
let fn = V.rebuilder
mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing donothing donothing
- ident expression donothing typeC init param donothing rule_elem
+ donothing donothing donothing donothing donothing
+ ident expression donothing typeC init param decl rule_elem
donothing donothing donothing donothing in
List.map fn.V.rebuilder_top_level minirules
V.rebuilder
mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
- donothing donothing astfvstatement_dots donothing
+ donothing donothing astfvstatement_dots donothing donothing
donothing donothing donothing donothing donothing donothing donothing
astfvrule_elem astfvstatement astfvcase_line astfvtoplevel donothing
[] -> []
| (metavars, rule)::rules ->
match rule with
- Ast.ScriptRule (_,_,_,_)
- | Ast.InitialScriptRule (_,_) | Ast.FinalScriptRule (_,_) ->
+ Ast.ScriptRule (_,_,_,_,script_vars,_) ->
+ (* why are metavars in rule, but outside for cocci rule??? *)
+ let bound = script_vars @ bound in
+ rule::(loop bound rules)
+ | Ast.InitialScriptRule (_,_,_,_) | Ast.FinalScriptRule (_,_,_,_) ->
(* bound stays as is because script rules have no names, so no
inheritance is possible *)
rule::(loop bound rules)
let option_default = ([],[]) in
let metaid (x,_,_,_) = x in
let mcode r mc =
- match Ast.get_pos_var mc with
- Ast.MetaPos(name,constraints,Ast.PER,_,_) ->
- ([metaid name],constraints)
- | Ast.MetaPos(name,constraints,Ast.ALL,_,_) ->
- ([],(metaid name)::constraints)
- | _ -> option_default in
+ List.fold_left
+ (function (a,b) ->
+ (function
+ Ast.MetaPos(name,constraints,Ast.PER,_,_) ->
+ ((metaid name)::a,constraints@b)
+ | Ast.MetaPos(name,constraints,Ast.ALL,_,_) ->
+ (a,(metaid name)::constraints@b)))
+ option_default (Ast.get_pos_var mc) in
let v =
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 donothing donothing donothing donothing donothing
donothing donothing donothing donothing donothing donothing in
match rule with
let collect_top_level_used_after metavar_rule_list =
+ let drop_virt = List.filter (function ("virtual",_) -> false | _ -> true) in
let (used_after,used_after_lists) =
List.fold_right
(function (metavar_list,r) ->
function (used_after,used_after_lists) ->
- let locally_defined = List.map Ast.get_meta_name metavar_list in
+ let locally_defined =
+ match r with
+ Ast.ScriptRule (_,_,_,_,free_vars,_) -> free_vars
+ | _ -> List.map Ast.get_meta_name metavar_list in
let continue_propagation =
List.filter (function x -> not(List.mem x locally_defined))
used_after in
let free_vars =
match r with
- Ast.ScriptRule (_,_,mv,_) ->
- List.map (function (_,(r,v)) -> (r,v)) mv
- | Ast.InitialScriptRule (_,_) | Ast.FinalScriptRule (_,_) -> []
+ Ast.ScriptRule (_,_,_,mv,_,_) ->
+ drop_virt(List.map (function (_,(r,v),_) -> (r,v)) mv)
+ | Ast.InitialScriptRule (_,_,_,_)
+ | Ast.FinalScriptRule (_,_,_,_) -> []
| Ast.CocciRule (_,_,rule,_,_) ->
- Common.union_set (nub (collect_all_rule_refs rule))
- (collect_in_plus metavar_list rule) in
+ drop_virt
+ (Common.union_set (nub (collect_all_rule_refs rule))
+ (collect_in_plus metavar_list rule)) in
let inherited =
List.filter (function x -> not (List.mem x locally_defined))
free_vars in
(function (metavars,r) ->
function used_after ->
match r with
- Ast.ScriptRule (_,_,_,_)
- | Ast.InitialScriptRule (_,_) | Ast.FinalScriptRule (_,_) ->
- ([], [used_after], [], [])
+ Ast.ScriptRule (_,_,_,_,_,_) (* no minirules, so nothing to do? *)
+ | Ast.InitialScriptRule (_,_,_,_) | Ast.FinalScriptRule (_,_,_,_) ->
+ ([], [used_after], [[]], [])
| Ast.CocciRule (name, rule_info, minirules, _,_) ->
collect_local_used_after metavars minirules used_after
)
List.map
(function (mv, r) ->
match r with
- Ast.ScriptRule _
+ Ast.ScriptRule _ (* doesn't declare position variables *)
| Ast.InitialScriptRule _ | Ast.FinalScriptRule _ -> []
| Ast.CocciRule (_,_,rule,_,_) ->
let positions =
HCoop / bpt / coccinelle.git / blobdiff