(*
- * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
+ * Copyright 2005-2010, 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.
+ *
+ * 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.
+ *)
+
+
+(*
+ * Copyright 2005-2010, 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.
*
| A.STARS _ -> failwith "not handling stars"
let (redots : 'a A.dots -> 'a list -> 'a A.dots)=fun eas easundots ->
- A.rewrap eas (
- match A.unwrap eas with
+ A.rewrap eas (
+ match A.unwrap eas with
| A.DOTS _ -> A.DOTS easundots
| A.CIRCLES _ -> A.CIRCLES easundots
| A.STARS _ -> A.STARS easundots
)
-let (need_unordered_initialisers : B.initialiser B.wrap2 list -> bool) =
- fun ibs ->
- ibs +> List.exists (fun (ib, icomma) ->
+let (need_unordered_initialisers : B.initialiser B.wrap2 list -> bool) =
+ fun ibs ->
+ ibs +> List.exists (fun (ib, icomma) ->
match B.unwrap ib with
- | B.InitDesignators _
- | B.InitFieldOld _
+ | B.InitDesignators _
+ | B.InitFieldOld _
| B.InitIndexOld _
-> true
- | B.InitExpr _
- | B.InitList _
+ | B.InitExpr _
+ | B.InitList _
-> false
)
* #include <linux/xxx.h> or last one in the serie of #includes in the
* .c.
*)
-type include_requirement =
+type include_requirement =
| IncludeMcodeBefore
- | IncludeMcodeAfter
+ | IncludeMcodeAfter
| IncludeNothing
-
+
(* todo? put in semantic_c.ml *)
-type info_ident =
- | Function
+type info_ident =
+ | Function
| LocalFunction (* entails Function *)
| DontKnow
* mcodekind, or add an argument to tag_with_mck such as "safe" that
* don't do the check_pos. Hence this DontCarePos constructor. *)
-let minusizer =
- ("fake","fake"),
+let minusizer =
+ ("fake","fake"),
{A.line = 0; A.column =0; A.strbef=[]; A.straft=[];},
(A.MINUS(A.DontCarePos,[],-1,[])),
A.NoMetaPos
-let generalize_mcode ia =
+let generalize_mcode ia =
let (s1, i, mck, pos) = ia in
let new_mck =
match mck with
| A.PLUS _ -> raise Impossible
- | A.CONTEXT (A.NoPos,x) ->
+ | A.CONTEXT (A.NoPos,x) ->
A.CONTEXT (A.DontCarePos,x)
- | A.MINUS (A.NoPos,inst,adj,x) ->
+ | A.MINUS (A.NoPos,inst,adj,x) ->
A.MINUS (A.DontCarePos,inst,adj,x)
- | A.CONTEXT ((A.FixPos _|A.DontCarePos), _)
+ | A.CONTEXT ((A.FixPos _|A.DontCarePos), _)
| A.MINUS ((A.FixPos _|A.DontCarePos), _, _, _)
->
raise Impossible
(*---------------------------------------------------------------------------*)
(* 0x0 is equivalent to 0, value format isomorphism *)
-let equal_c_int s1 s2 =
- try
+let equal_c_int s1 s2 =
+ try
int_of_string s1 =|= int_of_string s2
- with Failure("int_of_string") ->
+ with Failure("int_of_string") ->
s1 =$= s2
(*---------------------------------------------------------------------------*)
(* Normally A should reuse some types of Ast_c, so those
* functions should not exist.
- *
+ *
* update: but now Ast_c depends on A, so can't make too
* A depends on Ast_c, so have to stay with those equal_xxx
- * functions.
+ * functions.
*)
-let equal_unaryOp a b =
+let equal_unaryOp a b =
match a, b with
| A.GetRef , B.GetRef -> true
| A.DeRef , B.DeRef -> true
| A.Not , B.Not -> true
| _, B.GetRefLabel -> false (* todo cocci? *)
| _, (B.Not|B.Tilde|B.UnMinus|B.UnPlus|B.DeRef|B.GetRef) -> false
-
-let equal_arithOp a b =
+
+let equal_arithOp a b =
match a, b with
| A.Plus , B.Plus -> true
| A.Minus , B.Minus -> true
| _, (B.Xor|B.Or|B.And|B.DecRight|B.DecLeft|B.Mod|B.Div|B.Mul|B.Minus|B.Plus)
-> false
-let equal_logicalOp a b =
+let equal_logicalOp a b =
match a, b with
| A.Inf , B.Inf -> true
| A.Sup , B.Sup -> true
| _, (B.OrLog|B.AndLog|B.NotEq|B.Eq|B.SupEq|B.InfEq|B.Sup|B.Inf)
-> false
-let equal_assignOp a b =
+let equal_assignOp a b =
match a, b with
| A.SimpleAssign, B.SimpleAssign -> true
| A.OpAssign a, B.OpAssign b -> equal_arithOp a b
| _, (B.OpAssign _|B.SimpleAssign) -> false
-let equal_fixOp a b =
+let equal_fixOp a b =
match a, b with
| A.Dec, B.Dec -> true
| A.Inc, B.Inc -> true
| _, (B.Inc|B.Dec) -> false
-let equal_binaryOp a b =
+let equal_binaryOp a b =
match a, b with
| A.Arith a, B.Arith b -> equal_arithOp a b
| A.Logical a, B.Logical b -> equal_logicalOp a b
| _, (B.Logical _ | B.Arith _) -> false
-let equal_structUnion a b =
+let equal_structUnion a b =
match a, b with
| A.Struct, B.Struct -> true
| A.Union, B.Union -> true
| _, (B.Struct|B.Union) -> false
-let equal_sign a b =
+let equal_sign a b =
match a, b with
| A.Signed, B.Signed -> true
| A.Unsigned, B.UnSigned -> true
| _, (B.UnSigned|B.Signed) -> false
-let equal_storage a b =
+let equal_storage a b =
match a, b with
| A.Static , B.Sto B.Static
| A.Auto , B.Sto B.Auto
| A.Register , B.Sto B.Register
- | A.Extern , B.Sto B.Extern
+ | A.Extern , B.Sto B.Extern
-> true
| _, (B.NoSto | B.StoTypedef) -> false
| _, (B.Sto (B.Register|B.Static|B.Auto|B.Extern)) -> false
let equal_metavarval valu valu' =
match valu, valu' with
- | Ast_c.MetaIdVal a, Ast_c.MetaIdVal b -> a =$= b
+ | Ast_c.MetaIdVal (a,_), Ast_c.MetaIdVal (b,_) -> a =$= b
| Ast_c.MetaFuncVal a, Ast_c.MetaFuncVal b -> a =$= b
- | Ast_c.MetaLocalFuncVal a, Ast_c.MetaLocalFuncVal b ->
+ | Ast_c.MetaLocalFuncVal a, Ast_c.MetaLocalFuncVal b ->
(* do something more ? *)
a =$= b
* just isomorphisms). => TODO call isomorphism_c_c instead of
* =*=. Maybe would be easier to transform ast_c in ast_cocci
* and call the iso engine of julia. *)
- | Ast_c.MetaExprVal a, Ast_c.MetaExprVal b ->
+ | Ast_c.MetaExprVal (a,_), Ast_c.MetaExprVal (b,_) ->
Lib_parsing_c.al_expr a =*= Lib_parsing_c.al_expr b
- | Ast_c.MetaExprListVal a, Ast_c.MetaExprListVal b ->
+ | Ast_c.MetaExprListVal a, Ast_c.MetaExprListVal b ->
Lib_parsing_c.al_arguments a =*= Lib_parsing_c.al_arguments b
- | Ast_c.MetaStmtVal a, Ast_c.MetaStmtVal b ->
+ | Ast_c.MetaStmtVal a, Ast_c.MetaStmtVal b ->
Lib_parsing_c.al_statement a =*= Lib_parsing_c.al_statement b
- | Ast_c.MetaInitVal a, Ast_c.MetaInitVal b ->
+ | Ast_c.MetaInitVal a, Ast_c.MetaInitVal b ->
Lib_parsing_c.al_init a =*= Lib_parsing_c.al_init b
- | Ast_c.MetaTypeVal a, Ast_c.MetaTypeVal b ->
+ | Ast_c.MetaTypeVal a, Ast_c.MetaTypeVal b ->
(* old: Lib_parsing_c.al_type a =*= Lib_parsing_c.al_type b *)
C_vs_c.eq_type a b
-
+
| Ast_c.MetaListlenVal a, Ast_c.MetaListlenVal b -> a =|= b
- | Ast_c.MetaParamVal a, Ast_c.MetaParamVal b ->
+ | Ast_c.MetaParamVal a, Ast_c.MetaParamVal b ->
Lib_parsing_c.al_param a =*= Lib_parsing_c.al_param b
- | Ast_c.MetaParamListVal a, Ast_c.MetaParamListVal b ->
+ | Ast_c.MetaParamListVal a, Ast_c.MetaParamListVal b ->
Lib_parsing_c.al_params a =*= Lib_parsing_c.al_params b
- | Ast_c.MetaPosVal (posa1,posa2), Ast_c.MetaPosVal (posb1,posb2) ->
+ | Ast_c.MetaPosVal (posa1,posa2), Ast_c.MetaPosVal (posb1,posb2) ->
Ast_cocci.equal_pos posa1 posb1 && Ast_cocci.equal_pos posa2 posb2
| Ast_c.MetaPosValList l1, Ast_c.MetaPosValList l2 ->
know which one is which... *)
let equal_inh_metavarval valu valu'=
match valu, valu' with
- | Ast_c.MetaIdVal a, Ast_c.MetaIdVal b -> a =$= b
+ | Ast_c.MetaIdVal (a,_), Ast_c.MetaIdVal (b,_) -> a =$= b
| Ast_c.MetaFuncVal a, Ast_c.MetaFuncVal b -> a =$= b
- | Ast_c.MetaLocalFuncVal a, Ast_c.MetaLocalFuncVal b ->
+ | Ast_c.MetaLocalFuncVal a, Ast_c.MetaLocalFuncVal b ->
(* do something more ? *)
a =$= b
* just isomorphisms). => TODO call isomorphism_c_c instead of
* =*=. Maybe would be easier to transform ast_c in ast_cocci
* and call the iso engine of julia. *)
- | Ast_c.MetaExprVal a, Ast_c.MetaExprVal b ->
+ | Ast_c.MetaExprVal (a,_), Ast_c.MetaExprVal (b,_) ->
Lib_parsing_c.al_inh_expr a =*= Lib_parsing_c.al_inh_expr b
- | Ast_c.MetaExprListVal a, Ast_c.MetaExprListVal b ->
+ | Ast_c.MetaExprListVal a, Ast_c.MetaExprListVal b ->
Lib_parsing_c.al_inh_arguments a =*= Lib_parsing_c.al_inh_arguments b
- | Ast_c.MetaStmtVal a, Ast_c.MetaStmtVal b ->
+ | Ast_c.MetaStmtVal a, Ast_c.MetaStmtVal b ->
Lib_parsing_c.al_inh_statement a =*= Lib_parsing_c.al_inh_statement b
- | Ast_c.MetaInitVal a, Ast_c.MetaInitVal b ->
+ | Ast_c.MetaInitVal a, Ast_c.MetaInitVal b ->
Lib_parsing_c.al_inh_init a =*= Lib_parsing_c.al_inh_init b
- | Ast_c.MetaTypeVal a, Ast_c.MetaTypeVal b ->
+ | Ast_c.MetaTypeVal a, Ast_c.MetaTypeVal b ->
(* old: Lib_parsing_c.al_inh_type a =*= Lib_parsing_c.al_inh_type b *)
C_vs_c.eq_type a b
-
+
| Ast_c.MetaListlenVal a, Ast_c.MetaListlenVal b -> a =|= b
- | Ast_c.MetaParamVal a, Ast_c.MetaParamVal b ->
+ | Ast_c.MetaParamVal a, Ast_c.MetaParamVal b ->
Lib_parsing_c.al_param a =*= Lib_parsing_c.al_param b
- | Ast_c.MetaParamListVal a, Ast_c.MetaParamListVal b ->
+ | Ast_c.MetaParamListVal a, Ast_c.MetaParamListVal b ->
Lib_parsing_c.al_params a =*= Lib_parsing_c.al_params b
- | Ast_c.MetaPosVal (posa1,posa2), Ast_c.MetaPosVal (posb1,posb2) ->
+ | Ast_c.MetaPosVal (posa1,posa2), Ast_c.MetaPosVal (posb1,posb2) ->
Ast_cocci.equal_pos posa1 posb1 && Ast_cocci.equal_pos posa2 posb2
-
+
| Ast_c.MetaPosValList l1, Ast_c.MetaPosValList l2 ->
List.exists
(function (fla,cea,posa1,posa2) ->
(*---------------------------------------------------------------------------*)
(* could put in ast_c.ml, next to the split/unsplit_comma *)
-let split_signb_baseb_ii (baseb, ii) =
+let split_signb_baseb_ii (baseb, ii) =
let iis = ii +> List.map (fun info -> (B.str_of_info info), info) in
match baseb, iis with
-
+
| B.Void, ["void",i1] -> None, [i1]
-
+
| B.FloatType (B.CFloat),["float",i1] -> None, [i1]
| B.FloatType (B.CDouble),["double",i1] -> None, [i1]
| B.FloatType (B.CLongDouble),["long",i1;"double",i2] -> None,[i1;i2]
-
+
| B.IntType (B.CChar), ["char",i1] -> None, [i1]
(*---------------------------------------------------------------------------*)
-let rec unsplit_icomma xs =
+let rec unsplit_icomma xs =
match xs with
| [] -> []
- | x::y::xs ->
+ | x::y::xs ->
(match A.unwrap y with
- | A.IComma mcode ->
+ | A.IComma mcode ->
(x, y)::unsplit_icomma xs
| _ -> failwith "wrong ast_cocci in initializer"
)
- | _ ->
+ | _ ->
failwith ("wrong ast_cocci in initializer, should have pair " ^
"number of Icomma")
-let resplit_initialiser ibs iicomma =
+let resplit_initialiser ibs iicomma =
match iicomma, ibs with
| [], [] -> []
- | [], _ ->
+ | [], _ ->
failwith "should have a iicomma, do you generate fakeInfo in parser?"
- | _, [] ->
+ | _, [] ->
failwith "shouldn't have a iicomma"
- | [iicomma], x::xs ->
+ | [iicomma], x::xs ->
let elems = List.map fst (x::xs) in
let commas = List.map snd (x::xs) +> List.flatten in
let commas = commas @ [iicomma] in
- zip elems commas
+ zip elems commas
| _ -> raise Impossible
-let rec split_icomma xs =
+let rec split_icomma xs =
match xs with
| [] -> []
| (x,y)::xs -> x::y::split_icomma xs
-let rec unsplit_initialiser ibs_unsplit =
+let rec unsplit_initialiser ibs_unsplit =
match ibs_unsplit with
| [] -> [], [] (* empty iicomma *)
- | (x, commax)::xs ->
+ | (x, commax)::xs ->
let (xs, lastcomma) = unsplit_initialiser_bis commax xs in
(x, [])::xs, lastcomma
and unsplit_initialiser_bis comma_before = function
| [] -> [], [comma_before]
- | (x, commax)::xs ->
+ | (x, commax)::xs ->
let (xs, lastcomma) = unsplit_initialiser_bis commax xs in
(x, [comma_before])::xs, lastcomma
(*---------------------------------------------------------------------------*)
(* coupling: same in type_annotater_c.ml *)
-let structdef_to_struct_name ty =
- match ty with
- | qu, (B.StructUnion (su, sopt, fields), iis) ->
+let structdef_to_struct_name ty =
+ match ty with
+ | qu, (B.StructUnion (su, sopt, fields), iis) ->
(match sopt,iis with
- | Some s , [i1;i2;i3;i4] ->
+ | Some s , [i1;i2;i3;i4] ->
qu, (B.StructUnionName (su, s), [i1;i2])
- | None, _ ->
+ | None, _ ->
ty
-
+
| x -> raise Impossible
)
| _ -> raise Impossible
(*---------------------------------------------------------------------------*)
-let initialisation_to_affectation decl =
+let initialisation_to_affectation decl =
match decl with
| B.MacroDecl _ -> F.Decl decl
- | B.DeclList (xs, iis) ->
-
+ | B.DeclList (xs, iis) ->
+
(* todo?: should not do that if the variable is an array cos
* will have x[] = , mais de toute facon ca sera pas un InitExp
*)
(match xs with
| [] -> raise Impossible
- | [x] ->
+ | [x] ->
let ({B.v_namei = var;
B.v_type = returnType;
B.v_type_bis = tybis;
(match var with
- | Some (name, iniopt) ->
+ | Some (name, iniopt) ->
(match iniopt with
- | Some (iini, (B.InitExpr e, ii_empty2)) ->
+ | Some (iini, (B.InitExpr e, ii_empty2)) ->
let local =
match local with
| Ast_c.LocalDecl ->
Ast_c.LocalVar (Ast_c.info_of_type returnType) in
- let typexp =
+ let typexp =
(* old: Lib_parsing_c.al_type returnType
* but this type has not the typename completed so
* instead try to use tybis
*)
match !tybis with
- | Some ty_with_typename_completed ->
+ | Some ty_with_typename_completed ->
ty_with_typename_completed
| None -> raise Impossible
in
-
+
let typ =
ref (Some (typexp,local),
Ast_c.NotTest) in
let ident = name in
- let idexpr =
+ let idexpr =
Ast_c.mk_e_bis (B.Ident (ident)) typ Ast_c.noii
in
- let assign =
- Ast_c.mk_e
+ let assign =
+ Ast_c.mk_e
(B.Assignment (idexpr,B.SimpleAssign, e)) [iini] in
F.DefineExpr assign
-
+
| _ -> F.Decl decl
)
| _ -> F.Decl decl
)
- | x::xs ->
+ | x::xs ->
pr2_once "TODO: initialisation_to_affectation for multi vars";
(* todo? do a fold_left and generate 'x = a, y = b' etc, use
- * the Sequence expression operator of C and make an
+ * the Sequence expression operator of C and make an
* ExprStatement from that.
*)
F.Decl decl
(*****************************************************************************)
(* monad like stuff
* src: papers on parser combinators in haskell (cf a pearl by meijer in ICFP)
- *
+ *
* version0: was not tagging the SP, so just tag the C
- * val (>>=):
+ * val (>>=):
* (tin -> 'c tout) -> ('c -> (tin -> 'b tout)) -> (tin -> 'b tout)
* val return : 'b -> tin -> 'b tout
* val fail : tin -> 'b tout
- *
+ *
* version1: now also tag the SP so return a ('a * 'b)
*)
type mode = PatternMode | TransformMode
-module type PARAM =
- sig
+module type PARAM =
+ sig
type tin
type 'x tout
val mode : mode
- val (>>=):
- (tin -> ('a * 'b) tout) ->
- ('a -> 'b -> (tin -> ('c * 'd) tout)) ->
+ val (>>=):
+ (tin -> ('a * 'b) tout) ->
+ ('a -> 'b -> (tin -> ('c * 'd) tout)) ->
(tin -> ('c * 'd) tout)
val return : ('a * 'b) -> tin -> ('a *'b) tout
val fail : tin -> ('a * 'b) tout
- val (>||>) :
+ val (>||>) :
+ (tin -> 'x tout) ->
(tin -> 'x tout) ->
- (tin -> 'x tout) ->
(tin -> 'x tout)
- val (>|+|>) :
+ val (>|+|>) :
+ (tin -> 'x tout) ->
(tin -> 'x tout) ->
- (tin -> 'x tout) ->
(tin -> 'x tout)
val (>&&>) : (tin -> bool) -> (tin -> 'x tout) -> (tin -> 'x tout)
val tokenf : ('a A.mcode, B.info) matcher
val tokenf_mck : (A.mcodekind, B.info) matcher
- val distrf_e :
+ val distrf_e :
(A.meta_name A.mcode, B.expression) matcher
- val distrf_args :
+ val distrf_args :
(A.meta_name A.mcode, (Ast_c.argument, Ast_c.il) either list) matcher
- val distrf_type :
+ val distrf_type :
(A.meta_name A.mcode, Ast_c.fullType) matcher
- val distrf_params :
+ val distrf_params :
(A.meta_name A.mcode,
(Ast_c.parameterType, Ast_c.il) either list) matcher
- val distrf_param :
+ val distrf_param :
(A.meta_name A.mcode, Ast_c.parameterType) matcher
- val distrf_ini :
+ val distrf_ini :
(A.meta_name A.mcode, Ast_c.initialiser) matcher
- val distrf_node :
+ val distrf_node :
(A.meta_name A.mcode, Control_flow_c.node) matcher
- val distrf_define_params :
+ val distrf_define_params :
(A.meta_name A.mcode, (string Ast_c.wrap, Ast_c.il) either list)
matcher
- val distrf_struct_fields :
+ val distrf_struct_fields :
(A.meta_name A.mcode, B.field list) matcher
- val distrf_cst :
+ val distrf_cst :
(A.meta_name A.mcode, (B.constant, string) either B.wrap) matcher
- val cocciExp :
+ val cocciExp :
(A.expression, B.expression) matcher -> (A.expression, F.node) matcher
- val cocciExpExp :
+ val cocciExpExp :
(A.expression, B.expression) matcher ->
(A.expression, B.expression) matcher
- val cocciTy :
+ val cocciTy :
(A.fullType, B.fullType) matcher -> (A.fullType, F.node) matcher
- val cocciInit :
+ val cocciInit :
(A.initialiser, B.initialiser) matcher -> (A.initialiser, F.node) matcher
val envf :
- A.keep_binding -> A.inherited ->
+ A.keep_binding -> A.inherited ->
A.meta_name A.mcode * Ast_c.metavar_binding_kind *
(unit -> Common.filename * string * Ast_c.posl * Ast_c.posl) ->
(unit -> tin -> 'x tout) -> (tin -> 'x tout)
let tokenf = X.tokenf
(* should be raise Impossible when called from transformation.ml *)
-let fail2 () =
+let fail2 () =
match X.mode with
| PatternMode -> fail
| TransformMode -> raise Impossible
let (option: ('a,'b) matcher -> ('a option,'b option) matcher)= fun f t1 t2 ->
match (t1,t2) with
- | (Some t1, Some t2) ->
- f t1 t2 >>= (fun t1 t2 ->
+ | (Some t1, Some t2) ->
+ f t1 t2 >>= (fun t1 t2 ->
return (Some t1, Some t2)
)
| (None, None) -> return (None, None)
can match other things. But they no longer have the same type. Perhaps these
functions could be avoided by introducing an appropriate level of polymorphism,
but I don't know how to declare polymorphism across functors *)
-let dots2metavar (_,info,mcodekind,pos) = (("","..."),info,mcodekind,pos)
+let dots2metavar (_,info,mcodekind,pos) =
+ (("","..."),info,mcodekind,pos)
let metavar2dots (_,info,mcodekind,pos) = ("...",info,mcodekind,pos)
-let satisfies_iconstraint c id : bool =
+let satisfies_regexpconstraint c id : bool =
match c with
- A.IdNoConstraint -> true
- | A.IdNegIdSet l -> not (List.mem id l)
- | A.IdRegExp (_,recompiled) ->
- if Str.string_match recompiled id 0 then
- true
- else
- false
- | A.IdNotRegExp (_,recompiled) ->
- if Str.string_match recompiled id 0 then
- false
- else
- true
+ A.IdRegExp (_,recompiled) -> Str.string_match recompiled id 0
+ | A.IdNotRegExp (_,recompiled) -> not (Str.string_match recompiled id 0)
+
+let satisfies_iconstraint c id : bool =
+ not (List.mem id c)
let satisfies_econstraint c exp : bool =
- match Ast_c.unwrap_expr exp with
- Ast_c.Ident (name) ->
- (
- match name with
- Ast_c.RegularName rname -> satisfies_iconstraint c (Ast_c.unwrap_st rname)
- | Ast_c.CppConcatenatedName _ ->
- pr2_once ("WARNING: Unable to apply a constraint on a CppConcatenatedName identifier !"); true
- | Ast_c.CppVariadicName _ ->
- pr2_once ("WARNING: Unable to apply a constraint on a CppVariadicName identifier !"); true
- | Ast_c.CppIdentBuilder _ ->
- pr2_once ("WARNING: Unable to apply a constraint on a CppIdentBuilder identifier !"); true
- )
- | Ast_c.Constant cst ->
- (match cst with
- | Ast_c.String (str, _) -> satisfies_iconstraint c str
- | Ast_c.MultiString strlist ->
- pr2_once ("WARNING: Unable to apply a constraint on an multistring constant !"); true
- | Ast_c.Char (char , _) -> satisfies_iconstraint c char
- | Ast_c.Int (int , _) -> satisfies_iconstraint c int
- | Ast_c.Float (float, _) -> satisfies_iconstraint c float
- )
- | _ -> pr2_once ("WARNING: Unable to apply a constraint on an expression !"); true
+ let warning s = pr2_once ("WARNING: "^s); false in
+ match Ast_c.unwrap_expr exp with
+ Ast_c.Ident (name) ->
+ (match name with
+ Ast_c.RegularName rname ->
+ satisfies_regexpconstraint c (Ast_c.unwrap_st rname)
+ | Ast_c.CppConcatenatedName _ ->
+ warning
+ "Unable to apply a constraint on a CppConcatenatedName identifier!"
+ | Ast_c.CppVariadicName _ ->
+ warning
+ "Unable to apply a constraint on a CppVariadicName identifier!"
+ | Ast_c.CppIdentBuilder _ ->
+ warning
+ "Unable to apply a constraint on a CppIdentBuilder identifier!")
+ | Ast_c.Constant cst ->
+ (match cst with
+ | Ast_c.String (str, _) -> satisfies_regexpconstraint c str
+ | Ast_c.MultiString strlist ->
+ warning "Unable to apply a constraint on an multistring constant!"
+ | Ast_c.Char (char , _) -> satisfies_regexpconstraint c char
+ | Ast_c.Int (int , _) -> satisfies_regexpconstraint c int
+ | Ast_c.Float (float, _) -> satisfies_regexpconstraint c float)
+ | _ -> warning "Unable to apply a constraint on an expression!"
(*---------------------------------------------------------------------------*)
-(* toc:
+(* toc:
* - expression
* - ident
* - arguments
* - parameters
* - declaration
* - initialisers
- * - type
+ * - type
* - node
*)
(*---------------------------------------------------------------------------*)
let rec (expression: (A.expression, Ast_c.expression) matcher) =
- fun ea eb ->
+ fun ea eb ->
+ if A.get_test_exp ea && not (Ast_c.is_test eb) then fail
+ else
X.all_bound (A.get_inherited ea) >&&>
let wa x = A.rewrap ea x in
match A.unwrap ea, eb with
-
+
(* general case: a MetaExpr can match everything *)
| A.MetaExpr (ida,constraints,keep,opttypa,form,inherited),
(((expr, opttypb), ii) as expb) ->
- (* old: before have a MetaConst. Now we factorize and use 'form' to
+ (* old: before have a MetaConst. Now we factorize and use 'form' to
* differentiate between different cases *)
let rec matches_id = function
B.Ident(name) -> true
| (A.CONST,e) ->
let rec matches = function
B.Constant(c) -> true
- | B.Ident (nameidb) ->
- let s = Ast_c.str_of_name nameidb in
- if s =~ "^[A-Z_][A-Z_0-9]*$"
+ | B.Ident (nameidb) ->
+ let s = Ast_c.str_of_name nameidb in
+ if s =~ "^[A-Z_][A-Z_0-9]*$"
then begin
pr2_once ("warning: " ^ s ^ " treated as a constant");
true
(let (opttypb,_testb) = !opttypb in
match opttypa, opttypb with
| None, _ -> return ((),())
- | Some _, None ->
+ | Some _, None ->
pr2_once ("Missing type information. Certainly a pb in " ^
"annotate_typer.ml");
fail
acc >|+|> compatible_type ta tb) fail
) >>=
(fun () () ->
- match constraints with
- Ast_cocci.NoConstraint ->
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_expr expb) in
- X.envf keep inherited (ida, Ast_c.MetaExprVal expb, max_min)
- (fun () ->
- X.distrf_e ida expb >>=
- (fun ida expb ->
- return (
- A.MetaExpr (ida,constraints,keep,opttypa,form,inherited)+>
- A.rewrap ea,
- expb
- ))
- )
-
- | Ast_cocci.NotIdCstrt cstrt ->
- X.check_idconstraint satisfies_econstraint cstrt eb
- (fun () ->
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_expr expb) in
- X.envf keep inherited (ida, Ast_c.MetaExprVal expb, max_min)
- (fun () ->
- X.distrf_e ida expb >>=
- (fun ida expb ->
- return (
- A.MetaExpr (ida,constraints,keep,opttypa,form,inherited)+>
- A.rewrap ea,
- expb
- ))
- ))
-
- | Ast_cocci.NotExpCstrt cstrts ->
- X.check_constraints_ne expression cstrts eb
- (fun () ->
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_expr expb) in
- X.envf keep inherited (ida, Ast_c.MetaExprVal expb, max_min)
- (fun () ->
- X.distrf_e ida expb >>=
- (fun ida expb ->
- return (
- A.MetaExpr (ida,constraints,keep,opttypa,form,inherited)+>
- A.rewrap ea,
- expb
- ))
- )))
+ let meta_expr_val l x = Ast_c.MetaExprVal(x,l) in
+ match constraints with
+ Ast_cocci.NoConstraint -> return (meta_expr_val [],())
+ | Ast_cocci.NotIdCstrt cstrt ->
+ X.check_idconstraint satisfies_econstraint cstrt eb
+ (fun () -> return (meta_expr_val [],()))
+ | Ast_cocci.NotExpCstrt cstrts ->
+ X.check_constraints_ne expression cstrts eb
+ (fun () -> return (meta_expr_val [],()))
+ | Ast_cocci.SubExpCstrt cstrts ->
+ return (meta_expr_val cstrts,()))
+ >>=
+ (fun wrapper () ->
+ let max_min _ =
+ Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_expr expb) in
+ X.envf keep inherited (ida, wrapper expb, max_min)
+ (fun () ->
+ X.distrf_e ida expb >>=
+ (fun ida expb ->
+ return (
+ A.MetaExpr (ida,constraints,keep,opttypa,form,inherited)+>
+ A.rewrap ea,
+ expb
+ ))
+ ))
else fail
- (* old:
+ (* old:
* | A.MetaExpr(ida,false,opttypa,_inherited), expb ->
* D.distribute_mck (mcodekind ida) D.distribute_mck_e expb binding
- *
+ *
* but bug! because if have not tagged SP, then transform without doing
* any checks. Hopefully now have tagged SP technique.
*)
-
-
- (* old:
- * | A.Edots _, _ -> raise Impossible.
- *
- * In fact now can also have the Edots inside normal expression, not
- * just in arg lists. in 'x[...];' less: in if(<... x ... y ...>)
+
+
+ (* old:
+ * | A.Edots _, _ -> raise Impossible.
+ *
+ * In fact now can also have the Edots inside normal expression, not
+ * just in arg lists. in 'x[...];' less: in if(<... x ... y ...>)
*)
- | A.Edots (mcode, None), expb ->
- X.distrf_e (dots2metavar mcode) expb >>= (fun mcode expb ->
+ | A.Edots (mcode, None), expb ->
+ X.distrf_e (dots2metavar mcode) expb >>= (fun mcode expb ->
return (
- A.Edots (metavar2dots mcode, None) +> A.rewrap ea ,
+ A.Edots (metavar2dots mcode, None) +> A.rewrap ea ,
expb
))
-
-
+
+
| A.Edots (_, Some expr), _ -> failwith "not handling when on Edots"
-
-
+
+
| A.Ident ida, ((B.Ident (nameidb), typ),noii) ->
assert (null noii);
- ident_cpp DontKnow ida nameidb >>= (fun ida nameidb ->
+ ident_cpp DontKnow ida nameidb >>= (fun ida nameidb ->
return (
- ((A.Ident ida)) +> wa,
+ ((A.Ident ida)) +> wa,
((B.Ident (nameidb), typ),Ast_c.noii)
))
-
-
-
+
+
+
| A.MetaErr _, _ -> failwith "not handling MetaErr"
(* todo?: handle some isomorphisms in int/float ? can have different
* format : 1l can match a 1.
- *
+ *
* todo: normally string can contain some metavar too, so should
- * recurse on the string
+ * recurse on the string
*)
- | A.Constant (ia1), ((B.Constant (ib) , typ),ii) ->
+ | A.Constant (ia1), ((B.Constant (ib) , typ),ii) ->
(* for everything except the String case where can have multi elems *)
- let do1 () =
- let ib1 = tuple_of_list1 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- return (
- ((A.Constant ia1)) +> wa,
+ let do1 () =
+ let ib1 = tuple_of_list1 ii in
+ tokenf ia1 ib1 >>= (fun ia1 ib1 ->
+ return (
+ ((A.Constant ia1)) +> wa,
((B.Constant (ib), typ),[ib1])
))
in
- (match term ia1, ib with
- | A.Int x, B.Int (y,_) ->
- X.value_format_flag (fun use_value_equivalence ->
- if use_value_equivalence
- then
+ (match term ia1, ib with
+ | A.Int x, B.Int (y,_) ->
+ X.value_format_flag (fun use_value_equivalence ->
+ if use_value_equivalence
+ then
if equal_c_int x y
then do1()
else fail
- else
+ else
if x =$= y
then do1()
else fail
| A.String sa, B.String (sb,_kind) when sa =$= sb ->
(match ii with
- | [ib1] ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- return (
- ((A.Constant ia1)) +> wa,
+ | [ib1] ->
+ tokenf ia1 ib1 >>= (fun ia1 ib1 ->
+ return (
+ ((A.Constant ia1)) +> wa,
((B.Constant (ib), typ),[ib1])
))
| _ -> fail (* multi string, not handled *)
)
- | A.FunCall (ea, ia1, eas, ia2), ((B.FunCall (eb, ebs), typ),ii) ->
+ | A.FunCall (ea, ia1, eas, ia2), ((B.FunCall (eb, ebs), typ),ii) ->
(* todo: do special case to allow IdMetaFunc, cos doing the
* recursive call will be too late, match_ident will not have the
* info whether it was a function. todo: but how detect when do
* x.field = f; how know that f is a Func ? By having computed
* some information before the matching!
- *
+ *
* Allow match with FunCall containing types. Now ast_cocci allow
* type in parameter, and morover ast_cocci allow f(...) and those
- * ... could match type.
+ * ... could match type.
*)
let (ib1, ib2) = tuple_of_list2 ii in
expression ea eb >>= (fun ea eb ->
| A.Assignment (ea1, opa, ea2, simple),
- ((B.Assignment (eb1, opb, eb2), typ),ii) ->
+ ((B.Assignment (eb1, opb, eb2), typ),ii) ->
let (opbi) = tuple_of_list1 ii in
- if equal_assignOp (term opa) opb
+ if equal_assignOp (term opa) opb
then
- expression ea1 eb1 >>= (fun ea1 eb1 ->
- expression ea2 eb2 >>= (fun ea2 eb2 ->
- tokenf opa opbi >>= (fun opa opbi ->
+ expression ea1 eb1 >>= (fun ea1 eb1 ->
+ expression ea2 eb2 >>= (fun ea2 eb2 ->
+ tokenf opa opbi >>= (fun opa opbi ->
return (
((A.Assignment (ea1, opa, ea2, simple))) +> wa,
((B.Assignment (eb1, opb, eb2), typ), [opbi])
| A.CondExpr(ea1,ia1,ea2opt,ia2,ea3),((B.CondExpr(eb1,eb2opt,eb3),typ),ii) ->
let (ib1, ib2) = tuple_of_list2 ii in
- expression ea1 eb1 >>= (fun ea1 eb1 ->
- option expression ea2opt eb2opt >>= (fun ea2opt eb2opt ->
- expression ea3 eb3 >>= (fun ea3 eb3 ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
+ expression ea1 eb1 >>= (fun ea1 eb1 ->
+ option expression ea2opt eb2opt >>= (fun ea2opt eb2opt ->
+ expression ea3 eb3 >>= (fun ea3 eb3 ->
+ tokenf ia1 ib1 >>= (fun ia1 ib1 ->
+ tokenf ia2 ib2 >>= (fun ia2 ib2 ->
return (
((A.CondExpr(ea1,ia1,ea2opt,ia2,ea3))) +> wa,
((B.CondExpr (eb1, eb2opt, eb3),typ), [ib1;ib2])
))))))
(* todo?: handle some isomorphisms here ? *)
- | A.Postfix (ea, opa), ((B.Postfix (eb, opb), typ),ii) ->
+ | A.Postfix (ea, opa), ((B.Postfix (eb, opb), typ),ii) ->
let opbi = tuple_of_list1 ii in
if equal_fixOp (term opa) opb
then
- expression ea eb >>= (fun ea eb ->
- tokenf opa opbi >>= (fun opa opbi ->
+ expression ea eb >>= (fun ea eb ->
+ tokenf opa opbi >>= (fun opa opbi ->
return (
((A.Postfix (ea, opa))) +> wa,
((B.Postfix (eb, opb), typ),[opbi])
)))
else fail
-
-
- | A.Infix (ea, opa), ((B.Infix (eb, opb), typ),ii) ->
+
+
+ | A.Infix (ea, opa), ((B.Infix (eb, opb), typ),ii) ->
let opbi = tuple_of_list1 ii in
if equal_fixOp (term opa) opb
then
- expression ea eb >>= (fun ea eb ->
- tokenf opa opbi >>= (fun opa opbi ->
+ expression ea eb >>= (fun ea eb ->
+ tokenf opa opbi >>= (fun opa opbi ->
return (
((A.Infix (ea, opa))) +> wa,
((B.Infix (eb, opb), typ),[opbi])
)))
else fail
- | A.Unary (ea, opa), ((B.Unary (eb, opb), typ),ii) ->
+ | A.Unary (ea, opa), ((B.Unary (eb, opb), typ),ii) ->
let opbi = tuple_of_list1 ii in
if equal_unaryOp (term opa) opb
then
- expression ea eb >>= (fun ea eb ->
- tokenf opa opbi >>= (fun opa opbi ->
+ expression ea eb >>= (fun ea eb ->
+ tokenf opa opbi >>= (fun opa opbi ->
return (
((A.Unary (ea, opa))) +> wa,
((B.Unary (eb, opb), typ),[opbi])
)))
else fail
- | A.Binary (ea1, opa, ea2), ((B.Binary (eb1, opb, eb2), typ),ii) ->
+ | A.Binary (ea1, opa, ea2), ((B.Binary (eb1, opb, eb2), typ),ii) ->
let opbi = tuple_of_list1 ii in
if equal_binaryOp (term opa) opb
- then
- expression ea1 eb1 >>= (fun ea1 eb1 ->
- expression ea2 eb2 >>= (fun ea2 eb2 ->
- tokenf opa opbi >>= (fun opa opbi ->
+ then
+ expression ea1 eb1 >>= (fun ea1 eb1 ->
+ expression ea2 eb2 >>= (fun ea2 eb2 ->
+ tokenf opa opbi >>= (fun opa opbi ->
return (
((A.Binary (ea1, opa, ea2))) +> wa,
((B.Binary (eb1, opb, eb2), typ),[opbi]
)))))
else fail
- | A.Nested (ea1, opa, ea2), eb ->
+ | A.Nested (ea1, opa, ea2), eb ->
let rec loop eb =
- (if A.get_test_exp ea1 && not (Ast_c.is_test eb) then fail
- else expression ea1 eb) >|+|>
+ expression ea1 eb >|+|>
(match eb with
((B.Binary (eb1, opb, eb2), typ),ii)
when equal_binaryOp (term opa) opb ->
let opbi = tuple_of_list1 ii in
let left_to_right =
- (expression ea1 eb1 >>= (fun ea1 eb1 ->
- expression ea2 eb2 >>= (fun ea2 eb2 ->
- tokenf opa opbi >>= (fun opa opbi ->
+ (expression ea1 eb1 >>= (fun ea1 eb1 ->
+ expression ea2 eb2 >>= (fun ea2 eb2 ->
+ tokenf opa opbi >>= (fun opa opbi ->
return (
((A.Nested (ea1, opa, ea2))) +> wa,
((B.Binary (eb1, opb, eb2), typ),[opbi]
)))))) in
let right_to_left =
- (expression ea2 eb1 >>= (fun ea2 eb1 ->
- expression ea1 eb2 >>= (fun ea1 eb2 ->
- tokenf opa opbi >>= (fun opa opbi ->
+ (expression ea2 eb1 >>= (fun ea2 eb1 ->
+ expression ea1 eb2 >>= (fun ea1 eb2 ->
+ tokenf opa opbi >>= (fun opa opbi ->
return (
((A.Nested (ea1, opa, ea2))) +> wa,
((B.Binary (eb1, opb, eb2), typ),[opbi]
)))))) in
let in_left =
- (loop eb1 >>= (fun ea1 eb1 ->
- expression ea2 eb2 >>= (fun ea2 eb2 ->
- tokenf opa opbi >>= (fun opa opbi ->
+ (loop eb1 >>= (fun ea1 eb1 ->
+ expression ea2 eb2 >>= (fun ea2 eb2 ->
+ tokenf opa opbi >>= (fun opa opbi ->
return (
((A.Nested (ea1, opa, ea2))) +> wa,
((B.Binary (eb1, opb, eb2), typ),[opbi]
)))))) in
let in_right =
- (expression ea2 eb1 >>= (fun ea2 eb1 ->
- loop eb2 >>= (fun ea1 eb2 ->
- tokenf opa opbi >>= (fun opa opbi ->
+ (expression ea2 eb1 >>= (fun ea2 eb1 ->
+ loop eb2 >>= (fun ea1 eb2 ->
+ tokenf opa opbi >>= (fun opa opbi ->
return (
((A.Nested (ea1, opa, ea2))) +> wa,
((B.Binary (eb1, opb, eb2), typ),[opbi]
loop eb
(* todo?: handle some isomorphisms here ? (with pointers = Unary Deref) *)
- | A.ArrayAccess (ea1, ia1, ea2, ia2),((B.ArrayAccess (eb1, eb2), typ),ii) ->
+ | A.ArrayAccess (ea1, ia1, ea2, ia2),((B.ArrayAccess (eb1, eb2), typ),ii) ->
let (ib1, ib2) = tuple_of_list2 ii in
- expression ea1 eb1 >>= (fun ea1 eb1 ->
- expression ea2 eb2 >>= (fun ea2 eb2 ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
+ expression ea1 eb1 >>= (fun ea1 eb1 ->
+ expression ea2 eb2 >>= (fun ea2 eb2 ->
+ tokenf ia1 ib1 >>= (fun ia1 ib1 ->
+ tokenf ia2 ib2 >>= (fun ia2 ib2 ->
return (
((A.ArrayAccess (ea1, ia1, ea2, ia2))) +> wa,
((B.ArrayAccess (eb1, eb2),typ), [ib1;ib2])
(* todo?: handle some isomorphisms here ? *)
| A.RecordAccess (ea, ia1, ida), ((B.RecordAccess (eb, idb), typ),ii) ->
let (ib1) = tuple_of_list1 ii in
- ident_cpp DontKnow ida idb >>= (fun ida idb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- expression ea eb >>= (fun ea eb ->
+ ident_cpp DontKnow ida idb >>= (fun ida idb ->
+ tokenf ia1 ib1 >>= (fun ia1 ib1 ->
+ expression ea eb >>= (fun ea eb ->
return (
((A.RecordAccess (ea, ia1, ida))) +> wa,
((B.RecordAccess (eb, idb), typ), [ib1])
| A.RecordPtAccess (ea,ia1,ida),((B.RecordPtAccess (eb, idb), typ), ii) ->
let (ib1) = tuple_of_list1 ii in
- ident_cpp DontKnow ida idb >>= (fun ida idb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- expression ea eb >>= (fun ea eb ->
+ ident_cpp DontKnow ida idb >>= (fun ida idb ->
+ tokenf ia1 ib1 >>= (fun ia1 ib1 ->
+ expression ea eb >>= (fun ea eb ->
return (
((A.RecordPtAccess (ea, ia1, ida))) +> wa,
((B.RecordPtAccess (eb, idb), typ), [ib1])
))))
- (* todo?: handle some isomorphisms here ?
- * todo?: do some iso-by-absence on cast ?
+ (* todo?: handle some isomorphisms here ?
+ * todo?: do some iso-by-absence on cast ?
* by trying | ea, B.Case (typb, eb) -> match_e_e ea eb ?
*)
- | A.Cast (ia1, typa, ia2, ea), ((B.Cast (typb, eb), typ),ii) ->
+ | A.Cast (ia1, typa, ia2, ea), ((B.Cast (typb, eb), typ),ii) ->
let (ib1, ib2) = tuple_of_list2 ii in
- fullType typa typb >>= (fun typa typb ->
- expression ea eb >>= (fun ea eb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
+ fullType typa typb >>= (fun typa typb ->
+ expression ea eb >>= (fun ea eb ->
+ tokenf ia1 ib1 >>= (fun ia1 ib1 ->
+ tokenf ia2 ib2 >>= (fun ia2 ib2 ->
return (
((A.Cast (ia1, typa, ia2, ea))) +> wa,
((B.Cast (typb, eb),typ),[ib1;ib2])
)))))
- | A.SizeOfExpr (ia1, ea), ((B.SizeOfExpr (eb), typ),ii) ->
+ | A.SizeOfExpr (ia1, ea), ((B.SizeOfExpr (eb), typ),ii) ->
let ib1 = tuple_of_list1 ii in
- expression ea eb >>= (fun ea eb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
+ expression ea eb >>= (fun ea eb ->
+ tokenf ia1 ib1 >>= (fun ia1 ib1 ->
return (
((A.SizeOfExpr (ia1, ea))) +> wa,
((B.SizeOfExpr (eb), typ),[ib1])
)))
- | A.SizeOfType (ia1, ia2, typa, ia3), ((B.SizeOfType typb, typ),ii) ->
+ | A.SizeOfType (ia1, ia2, typa, ia3), ((B.SizeOfType typb, typ),ii) ->
let (ib1,ib2,ib3) = tuple_of_list3 ii in
- fullType typa typb >>= (fun typa typb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
+ fullType typa typb >>= (fun typa typb ->
+ tokenf ia1 ib1 >>= (fun ia1 ib1 ->
+ tokenf ia2 ib2 >>= (fun ia2 ib2 ->
+ tokenf ia3 ib3 >>= (fun ia3 ib3 ->
return (
((A.SizeOfType (ia1, ia2, typa, ia3))) +> wa,
((B.SizeOfType (typb),typ),[ib1;ib2;ib3])
(* todo? iso ? allow all the combinations ? *)
- | A.Paren (ia1, ea, ia2), ((B.ParenExpr (eb), typ),ii) ->
+ | A.Paren (ia1, ea, ia2), ((B.ParenExpr (eb), typ),ii) ->
let (ib1, ib2) = tuple_of_list2 ii in
- expression ea eb >>= (fun ea eb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
+ expression ea eb >>= (fun ea eb ->
+ tokenf ia1 ib1 >>= (fun ia1 ib1 ->
+ tokenf ia2 ib2 >>= (fun ia2 ib2 ->
return (
((A.Paren (ia1, ea, ia2))) +> wa,
((B.ParenExpr (eb), typ), [ib1;ib2])
))))
- | A.NestExpr(exps,None,true), eb ->
+ | A.NestExpr(starter,exps,ender,None,true), eb ->
+ (match A.get_mcodekind starter with
+ A.MINUS _ -> failwith "TODO: only context nests supported"
+ | _ -> ());
(match A.unwrap exps with
A.DOTS [exp] ->
- X.cocciExpExp expression exp eb >>= (fun exp eb ->
+ X.cocciExpExp expression exp eb >>= (fun exp eb ->
return (
- (A.NestExpr(A.rewrap exps (A.DOTS [exp]),None,true)) +> wa,
+ (A.NestExpr
+ (starter,A.rewrap exps (A.DOTS [exp]),ender,None,true)) +> wa,
eb
)
)
| A.NestExpr _, _ ->
failwith "only handling multi and no when code in a nest expr"
- (* only in arg lists or in define body *)
+ (* only in arg lists or in define body *)
| A.TypeExp _, _ -> fail
(* only in arg lists *)
- | A.MetaExprList _, _
- | A.EComma _, _
- | A.Ecircles _, _
- | A.Estars _, _
+ | A.MetaExprList _, _
+ | A.EComma _, _
+ | A.Ecircles _, _
+ | A.Estars _, _
->
raise Impossible
- | A.DisjExpr eas, eb ->
+ | A.DisjExpr eas, eb ->
eas +> List.fold_left (fun acc ea -> acc >|+|> (expression ea eb)) fail
- | A.UniqueExp _,_ | A.OptExp _,_ ->
+ | A.UniqueExp _,_ | A.OptExp _,_ ->
failwith "not handling Opt/Unique/Multi on expr"
(* Because of Exp cant put a raise Impossible; have to put a fail *)
- (* have not a counter part in coccinelle, for the moment *)
- | _, ((B.Sequence _,_),_)
- | _, ((B.StatementExpr _,_),_)
- | _, ((B.Constructor _,_),_)
+ (* have not a counter part in coccinelle, for the moment *)
+ | _, ((B.Sequence _,_),_)
+ | _, ((B.StatementExpr _,_),_)
+ | _, ((B.Constructor _,_),_)
-> fail
- | _,
+ | _,
(((B.Cast (_, _)|B.ParenExpr _|B.SizeOfType _|B.SizeOfExpr _|
B.RecordPtAccess (_, _)|
B.RecordAccess (_, _)|B.ArrayAccess (_, _)|
(* ------------------------------------------------------------------------- *)
-and (ident_cpp: info_ident -> (A.ident, B.name) matcher) =
+and (ident_cpp: info_ident -> (A.ident, B.name) matcher) =
fun infoidb ida idb ->
match idb with
- | B.RegularName (s, iis) ->
+ | B.RegularName (s, iis) ->
let iis = tuple_of_list1 iis in
- ident infoidb ida (s, iis) >>= (fun ida (s,iis) ->
+ ident infoidb ida (s, iis) >>= (fun ida (s,iis) ->
return (
- ida,
+ ida,
(B.RegularName (s, [iis]))
))
| B.CppConcatenatedName _ | B.CppVariadicName _ |B.CppIdentBuilder _
would require implementing an appropriate distr function *)
fail
-and (ident: info_ident -> (A.ident, string * Ast_c.info) matcher) =
+and (ident: info_ident -> (A.ident, string * Ast_c.info) matcher) =
fun infoidb ida ((idb, iib)) -> (* (idb, iib) as ib *)
+ let check_constraints constraints idb =
+ let meta_id_val l x = Ast_c.MetaIdVal(x,l) in
+ match constraints with
+ A.IdNoConstraint -> return (meta_id_val [],())
+ | A.IdNegIdSet (str,meta) ->
+ X.check_idconstraint satisfies_iconstraint str idb
+ (fun () -> return (meta_id_val meta,()))
+ | A.IdRegExpConstraint re ->
+ X.check_idconstraint satisfies_regexpconstraint re idb
+ (fun () -> return (meta_id_val [],())) in
X.all_bound (A.get_inherited ida) >&&>
match A.unwrap ida with
- | A.Id sa ->
+ | A.Id sa ->
if (term sa) =$= idb then
- tokenf sa iib >>= (fun sa iib ->
+ tokenf sa iib >>= (fun sa iib ->
return (
((A.Id sa)) +> A.rewrap ida,
(idb, iib)
))
else fail
- | A.MetaId(mida,constraints,keep,inherited) ->
- X.check_idconstraint satisfies_iconstraint constraints idb
- (fun () ->
+ | A.MetaId(mida,constraints,keep,inherited) ->
+ check_constraints constraints idb >>=
+ (fun wrapper () ->
let max_min _ = Lib_parsing_c.lin_col_by_pos [iib] in
(* use drop_pos for ids so that the pos is not added a second time in
the call to tokenf *)
- X.envf keep inherited (A.drop_pos mida, Ast_c.MetaIdVal (idb), max_min)
- (fun () ->
- tokenf mida iib >>= (fun mida iib ->
+ X.envf keep inherited (A.drop_pos mida, wrapper idb, max_min)
+ (fun () ->
+ tokenf mida iib >>= (fun mida iib ->
return (
((A.MetaId (mida, constraints, keep, inherited)) +> A.rewrap ida,
(idb, iib)
)))
))
- | A.MetaFunc(mida,constraints,keep,inherited) ->
+ | A.MetaFunc(mida,constraints,keep,inherited) ->
let is_function _ =
- X.check_idconstraint satisfies_iconstraint constraints idb
- (fun () ->
+ check_constraints constraints idb >>=
+ (fun wrapper () ->
let max_min _ = Lib_parsing_c.lin_col_by_pos [iib] in
X.envf keep inherited (A.drop_pos mida,Ast_c.MetaFuncVal idb,max_min)
(fun () ->
- tokenf mida iib >>= (fun mida iib ->
+ tokenf mida iib >>= (fun mida iib ->
return (
((A.MetaFunc(mida,constraints,keep,inherited)))+>A.rewrap ida,
(idb, iib)
))
)) in
- (match infoidb with
+ (match infoidb with
| LocalFunction | Function -> is_function()
| DontKnow ->
failwith "MetaFunc, need more semantic info about id"
(if idb =~ "^[A-Z_][A-Z_0-9]*$" then fail else is_function())*)
)
- | A.MetaLocalFunc(mida,constraints,keep,inherited) ->
- (match infoidb with
- | LocalFunction ->
- X.check_idconstraint satisfies_iconstraint constraints idb
- (fun () ->
+ | A.MetaLocalFunc(mida,constraints,keep,inherited) ->
+ (match infoidb with
+ | LocalFunction ->
+ check_constraints constraints idb >>=
+ (fun wrapper () ->
let max_min _ = Lib_parsing_c.lin_col_by_pos [iib] in
X.envf keep inherited
(A.drop_pos mida,Ast_c.MetaLocalFuncVal idb, max_min)
(fun () ->
- tokenf mida iib >>= (fun mida iib ->
+ tokenf mida iib >>= (fun mida iib ->
return (
((A.MetaLocalFunc(mida,constraints,keep,inherited)))
+> A.rewrap ida,
| DontKnow -> failwith "MetaLocalFunc, need more semantic info about id"
)
- | A.OptIdent _ | A.UniqueIdent _ ->
+ | A.OptIdent _ | A.UniqueIdent _ ->
failwith "not handling Opt/Unique for ident"
(* ------------------------------------------------------------------------- *)
-and (arguments: sequence ->
- (A.expression list, Ast_c.argument Ast_c.wrap2 list) matcher) =
+and (arguments: sequence ->
+ (A.expression list, Ast_c.argument Ast_c.wrap2 list) matcher) =
fun seqstyle eas ebs ->
match seqstyle with
| Unordered -> failwith "not handling ooo"
- | Ordered ->
- arguments_bis eas (Ast_c.split_comma ebs) >>= (fun eas ebs_splitted ->
+ | Ordered ->
+ arguments_bis eas (Ast_c.split_comma ebs) >>= (fun eas ebs_splitted ->
return (eas, (Ast_c.unsplit_comma ebs_splitted))
)
-(* because '...' can match nothing, need to take care when have
+(* because '...' can match nothing, need to take care when have
* ', ...' or '...,' as in f(..., X, Y, ...). It must match
* f(1,2) for instance.
* So I have added special cases such as (if startxs = []) and code
* in the Ecomma matching rule.
- *
+ *
* old: Must do some try, for instance when f(...,X,Y,...) have to
* test the transfo for all the combinaitions and if multiple transfo
* possible ? pb ? => the type is to return a expression option ? use
* update: with the tag-SP approach, no more a problem.
*)
-and arguments_bis = fun eas ebs ->
+and arguments_bis = fun eas ebs ->
match eas, ebs with
| [], [] -> return ([], [])
| [], eb::ebs -> fail
- | ea::eas, ebs ->
+ | ea::eas, ebs ->
X.all_bound (A.get_inherited ea) >&&>
(match A.unwrap ea, ebs with
- | A.Edots (mcode, optexpr), ys ->
+ | A.Edots (mcode, optexpr), ys ->
(* todo: if optexpr, then a WHEN and so may have to filter yys *)
if optexpr <> None then failwith "not handling when in argument";
(* '...' can take more or less the beginnings of the arguments *)
let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
- startendxs +> List.fold_left (fun acc (startxs, endxs) ->
+ startendxs +> List.fold_left (fun acc (startxs, endxs) ->
acc >||> (
(* allow '...', and maybe its associated ',' to match nothing.
(if null startxs
then
if mcode_contain_plus (mcodekind mcode)
- then fail
+ then fail
(* failwith "I have no token that I could accroche myself on" *)
else return (dots2metavar mcode, [])
- else
+ else
(* subtil: we dont want the '...' to match until the
* comma. cf -test pb_params_iso. We would get at
* "already tagged" error.
*)
(match Common.last startxs with
| Right _ -> fail
- | Left _ ->
+ | Left _ ->
X.distrf_args (dots2metavar mcode) startxs
)
)
>>= (fun mcode startxs ->
let mcode = metavar2dots mcode in
- arguments_bis eas endxs >>= (fun eas endxs ->
+ arguments_bis eas endxs >>= (fun eas endxs ->
return (
(A.Edots (mcode, optexpr) +> A.rewrap ea) ::eas,
startxs ++ endxs
)))
)
- ) fail
+ ) fail
- | A.EComma ia1, Right ii::ebs ->
+ | A.EComma ia1, Right ii::ebs ->
let ib1 = tuple_of_list1 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- arguments_bis eas ebs >>= (fun eas ebs ->
+ tokenf ia1 ib1 >>= (fun ia1 ib1 ->
+ arguments_bis eas ebs >>= (fun eas ebs ->
return (
(A.EComma ia1 +> A.rewrap ea)::eas,
(Right [ib1])::ebs
)
))
- | A.EComma ia1, ebs ->
+ | A.EComma ia1, ebs ->
(* allow ',' to maching nothing. optional comma trick *)
if mcode_contain_plus (mcodekind ia1)
then fail
| A.MetaExprList(ida,leninfo,keep,inherited),ys ->
let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
- startendxs +> List.fold_left (fun acc (startxs, endxs) ->
+ startendxs +> List.fold_left (fun acc (startxs, endxs) ->
acc >||> (
let ok =
if null startxs
then
if mcode_contain_plus (mcodekind ida)
- then false
+ then false
(* failwith "no token that I could accroche myself on" *)
else true
- else
+ else
(match Common.last startxs with
| Right _ -> false
| Left _ -> true
in
if not ok
then fail
- else
+ else
let startxs' = Ast_c.unsplit_comma startxs in
let len = List.length startxs' in
(lenname, Ast_c.MetaListlenVal (len), max_min)
| None -> function f -> f()
)
- (fun () ->
+ (fun () ->
let max_min _ =
Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_args startxs) in
X.envf keep inherited
(ida, Ast_c.MetaExprListVal startxs', max_min)
- (fun () ->
+ (fun () ->
if null startxs
then return (ida, [])
else X.distrf_args ida (Ast_c.split_comma startxs')
)
- >>= (fun ida startxs ->
- arguments_bis eas endxs >>= (fun eas endxs ->
+ >>= (fun ida startxs ->
+ arguments_bis eas endxs >>= (fun eas endxs ->
return (
(A.MetaExprList(ida,leninfo,keep,inherited))
+> A.rewrap ea::eas,
))
)
)
- )) fail
+ )) fail
- | _unwrapx, (Left eb)::ebs ->
- argument ea eb >>= (fun ea eb ->
- arguments_bis eas ebs >>= (fun eas ebs ->
+ | _unwrapx, (Left eb)::ebs ->
+ argument ea eb >>= (fun ea eb ->
+ arguments_bis eas ebs >>= (fun eas ebs ->
return (ea::eas, Left eb::ebs)
))
| _unwrapx, (Right y)::ys -> raise Impossible
| _unwrapx, [] -> fail
)
-
-
+
+
and argument arga argb =
X.all_bound (A.get_inherited arga) >&&>
match A.unwrap arga, argb with
- | A.TypeExp tya,
+ | A.TypeExp tya,
Right (B.ArgType {B.p_register=b,iib; p_namei=sopt;p_type=tyb}) ->
if b || sopt <> None
- then
+ then
(* failwith "the argument have a storage and ast_cocci does not have"*)
fail
- else
+ else
(* b = false and sopt = None *)
- fullType tya tyb >>= (fun tya tyb ->
+ fullType tya tyb >>= (fun tya tyb ->
return (
(A.TypeExp tya) +> A.rewrap arga,
(Right (B.ArgType {B.p_register=(b,iib);
(* ------------------------------------------------------------------------- *)
(* todo? facto code with argument ? *)
-and (parameters: sequence ->
+and (parameters: sequence ->
(A.parameterTypeDef list, Ast_c.parameterType Ast_c.wrap2 list)
- matcher) =
+ matcher) =
fun seqstyle eas ebs ->
match seqstyle with
| Unordered -> failwith "not handling ooo"
- | Ordered ->
- parameters_bis eas (Ast_c.split_comma ebs) >>= (fun eas ebs_splitted ->
+ | Ordered ->
+ parameters_bis eas (Ast_c.split_comma ebs) >>= (fun eas ebs_splitted ->
return (eas, (Ast_c.unsplit_comma ebs_splitted))
)
-and parameters_bis eas ebs =
+and parameters_bis eas ebs =
match eas, ebs with
| [], [] -> return ([], [])
| [], eb::ebs -> fail
sometimes there is a Param and sometimes a ParamList *)
X.all_bound (A.get_inherited ea) >&&>
(match A.unwrap ea, ebs with
- | A.Pdots (mcode), ys ->
+ | A.Pdots (mcode), ys ->
(* '...' can take more or less the beginnings of the arguments *)
let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
- startendxs +> List.fold_left (fun acc (startxs, endxs) ->
+ startendxs +> List.fold_left (fun acc (startxs, endxs) ->
acc >||> (
(if null startxs
then
if mcode_contain_plus (mcodekind mcode)
- then fail
+ then fail
(* failwith "I have no token that I could accroche myself on"*)
else return (dots2metavar mcode, [])
- else
+ else
(match Common.last startxs with
| Right _ -> fail
- | Left _ ->
+ | Left _ ->
X.distrf_params (dots2metavar mcode) startxs
)
) >>= (fun mcode startxs ->
let mcode = metavar2dots mcode in
- parameters_bis eas endxs >>= (fun eas endxs ->
+ parameters_bis eas endxs >>= (fun eas endxs ->
return (
(A.Pdots (mcode) +> A.rewrap ea) ::eas,
startxs ++ endxs
)))
)
- ) fail
+ ) fail
- | A.PComma ia1, Right ii::ebs ->
+ | A.PComma ia1, Right ii::ebs ->
let ib1 = tuple_of_list1 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- parameters_bis eas ebs >>= (fun eas ebs ->
+ tokenf ia1 ib1 >>= (fun ia1 ib1 ->
+ parameters_bis eas ebs >>= (fun eas ebs ->
return (
(A.PComma ia1 +> A.rewrap ea)::eas,
(Right [ib1])::ebs
)
))
- | A.PComma ia1, ebs ->
+ | A.PComma ia1, ebs ->
(* try optional comma trick *)
if mcode_contain_plus (mcodekind ia1)
then fail
| A.MetaParamList(ida,leninfo,keep,inherited),ys->
let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
- startendxs +> List.fold_left (fun acc (startxs, endxs) ->
+ startendxs +> List.fold_left (fun acc (startxs, endxs) ->
acc >||> (
let ok =
if null startxs
then
if mcode_contain_plus (mcodekind ida)
- then false
+ then false
(* failwith "I have no token that I could accroche myself on" *)
else true
- else
+ else
(match Common.last startxs with
| Right _ -> false
| Left _ -> true
in
if not ok
then fail
- else
+ else
let startxs' = Ast_c.unsplit_comma startxs in
let len = List.length startxs' in
let max_min _ =
Lib_parsing_c.lin_col_by_pos
(Lib_parsing_c.ii_of_params startxs) in
- X.envf keep inherited
+ X.envf keep inherited
(ida, Ast_c.MetaParamListVal startxs', max_min)
- (fun () ->
+ (fun () ->
if null startxs
then return (ida, [])
else X.distrf_params ida (Ast_c.split_comma startxs')
- ) >>= (fun ida startxs ->
- parameters_bis eas endxs >>= (fun eas endxs ->
+ ) >>= (fun ida startxs ->
+ parameters_bis eas endxs >>= (fun eas endxs ->
return (
(A.MetaParamList(ida,leninfo,keep,inherited))
+> A.rewrap ea::eas,
))
)
))
- ) fail
+ ) fail
- | A.VoidParam ta, ys ->
+ | A.VoidParam ta, ys ->
(match eas, ebs with
- | [], [Left eb] ->
+ | [], [Left eb] ->
let {B.p_register=(hasreg,iihasreg);
p_namei = idbopt;
p_type=tb; } = eb in
-
+
if idbopt =*= None && not hasreg
- then
- match tb with
- | (qub, (B.BaseType B.Void,_)) ->
- fullType ta tb >>= (fun ta tb ->
+ then
+ match tb with
+ | (qub, (B.BaseType B.Void,_)) ->
+ fullType ta tb >>= (fun ta tb ->
return (
[(A.VoidParam ta) +> A.rewrap ea],
[Left {B.p_register=(hasreg, iihasreg);
| _ -> fail
)
- | (A.OptParam _ | A.UniqueParam _), _ ->
+ | (A.OptParam _ | A.UniqueParam _), _ ->
failwith "handling Opt/Unique for Param"
| A.Pcircles (_), ys -> raise Impossible (* in Ordered mode *)
- | A.MetaParam (ida,keep,inherited), (Left eb)::ebs ->
+ | A.MetaParam (ida,keep,inherited), (Left eb)::ebs ->
(* todo: use quaopt, hasreg ? *)
let max_min _ =
Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_param eb) in
- X.envf keep inherited (ida,Ast_c.MetaParamVal eb,max_min) (fun () ->
+ X.envf keep inherited (ida,Ast_c.MetaParamVal eb,max_min) (fun () ->
X.distrf_param ida eb
- ) >>= (fun ida eb ->
- parameters_bis eas ebs >>= (fun eas ebs ->
+ ) >>= (fun ida eb ->
+ parameters_bis eas ebs >>= (fun eas ebs ->
return (
(A.MetaParam(ida,keep,inherited))+> A.rewrap ea::eas,
(Left eb)::ebs
)))
- | A.Param (typa, idaopt), (Left eb)::ebs ->
+ | A.Param (typa, idaopt), (Left eb)::ebs ->
(*this should succeed if the C code has a name, and fail otherwise*)
- parameter (idaopt, typa) eb >>= (fun (idaopt, typa) eb ->
- parameters_bis eas ebs >>= (fun eas ebs ->
+ parameter (idaopt, typa) eb >>= (fun (idaopt, typa) eb ->
+ parameters_bis eas ebs >>= (fun eas ebs ->
return (
(A.Param (typa, idaopt))+> A.rewrap ea :: eas,
(Left eb)::ebs
)))
-
+
| _unwrapx, (Right y)::ys -> raise Impossible
| _unwrapx, [] -> fail
)
-
+
(*
-let split_register_param = fun (hasreg, idb, ii_b_s) ->
+let split_register_param = fun (hasreg, idb, ii_b_s) ->
match hasreg, idb, ii_b_s with
| false, Some s, [i1] -> Left (s, [], i1)
| true, Some s, [i1;i2] -> Left (s, [i1], i2)
p_namei = nameidbopt;
p_type = typb;} = paramb in
- fullType typa typb >>= (fun typa typb ->
+ fullType typa typb >>= (fun typa typb ->
match idaopt, nameidbopt with
- | Some ida, Some nameidb ->
+ | Some ida, Some nameidb ->
(* todo: if minus on ida, should also minus the iihasreg ? *)
- ident_cpp DontKnow ida nameidb >>= (fun ida nameidb ->
+ ident_cpp DontKnow ida nameidb >>= (fun ida nameidb ->
return (
(Some ida, typa),
{B.p_register = (hasreg, iihasreg);
p_namei = Some (nameidb);
p_type = typb}
))
-
- | None, None ->
+
+ | None, None ->
return (
(None, typa),
{B.p_register=(hasreg,iihasreg);
p_namei = None;
p_type = typb;}
)
-
+
(* why handle this case ? because of transform_proto ? we may not
* have an ident in the proto.
- * If have some plus on ida ? do nothing about ida ?
+ * If have some plus on ida ? do nothing about ida ?
*)
(* not anymore !!! now that julia is handling the proto.
- | _, Right iihasreg ->
+ | _, Right iihasreg ->
return (
(idaopt, typa),
((hasreg, None, typb), iihasreg)
(* ------------------------------------------------------------------------- *)
and (declaration: (A.mcodekind * bool * A.declaration,B.declaration) matcher) =
- fun (mckstart, allminus, decla) declb ->
+ fun (mckstart, allminus, decla) declb ->
X.all_bound (A.get_inherited decla) >&&>
match A.unwrap decla, declb with
* commencer le reste du match au premier statement. Alors, ca matche
* n'importe quelle declaration. On n'a pas besoin d'ajouter
* quoi que ce soit dans l'environnement. C'est une sorte de DDots.
- *
+ *
* When the SP want to remove the whole function, the minus is not
* on the MetaDecl but on the MetaRuleElem. So there should
* be no transform of MetaDecl, just matching are allowed.
- | _, (B.DeclList ([var], iiptvirgb::iifakestart::iisto)) ->
+ | _, (B.DeclList ([var], iiptvirgb::iifakestart::iisto)) ->
onedecl allminus decla (var,iiptvirgb,iisto) >>=
(fun decla (var,iiptvirgb,iisto)->
- X.tokenf_mck mckstart iifakestart >>= (fun mckstart iifakestart ->
+ X.tokenf_mck mckstart iifakestart >>= (fun mckstart iifakestart ->
return (
(mckstart, allminus, decla),
(B.DeclList ([var], iiptvirgb::iifakestart::iisto))
)))
-
- | _, (B.DeclList (xs, iiptvirgb::iifakestart::iisto)) ->
+
+ | _, (B.DeclList (xs, iiptvirgb::iifakestart::iisto)) ->
if X.mode =*= PatternMode
then
- xs +> List.fold_left (fun acc var ->
+ xs +> List.fold_left (fun acc var ->
acc >||> (
X.tokenf_mck mckstart iifakestart >>= (fun mckstart iifakestart ->
- onedecl allminus decla (var, iiptvirgb, iisto) >>=
- (fun decla (var, iiptvirgb, iisto) ->
+ onedecl allminus decla (var, iiptvirgb, iisto) >>=
+ (fun decla (var, iiptvirgb, iisto) ->
return (
(mckstart, allminus, decla),
(B.DeclList ([var], iiptvirgb::iifakestart::iisto))
)))))
fail
- else
+ else
failwith "More that one variable in decl. Have to split to transform."
| A.MacroDecl (sa,lpa,eas,rpa,enda), B.MacroDecl ((sb,ebs),ii) ->
- let (iisb, lpb, rpb, iiendb, iifakestart, iistob) =
+ let (iisb, lpb, rpb, iiendb, iifakestart, iistob) =
(match ii with
- | iisb::lpb::rpb::iiendb::iifakestart::iisto ->
+ | iisb::lpb::rpb::iiendb::iifakestart::iisto ->
(iisb,lpb,rpb,iiendb, iifakestart,iisto)
| _ -> raise Impossible
) in
- (if allminus
+ (if allminus
then minusize_list iistob
else return ((), iistob)
) >>= (fun () iistob ->
- X.tokenf_mck mckstart iifakestart >>= (fun mckstart iifakestart ->
+ X.tokenf_mck mckstart iifakestart >>= (fun mckstart iifakestart ->
ident DontKnow sa (sb, iisb) >>= (fun sa (sb, iisb) ->
- tokenf lpa lpb >>= (fun lpa lpb ->
- tokenf rpa rpb >>= (fun rpa rpb ->
- tokenf enda iiendb >>= (fun enda iiendb ->
- arguments (seqstyle eas) (A.undots eas) ebs >>= (fun easundots ebs ->
+ tokenf lpa lpb >>= (fun lpa lpb ->
+ tokenf rpa rpb >>= (fun rpa rpb ->
+ tokenf enda iiendb >>= (fun enda iiendb ->
+ arguments (seqstyle eas) (A.undots eas) ebs >>= (fun easundots ebs ->
let eas = redots eas easundots in
return (
- (mckstart, allminus,
- (A.MacroDecl (sa,lpa,eas,rpa,enda)) +> A.rewrap decla),
+ (mckstart, allminus,
+ (A.MacroDecl (sa,lpa,eas,rpa,enda)) +> A.rewrap decla),
(B.MacroDecl ((sb,ebs),
[iisb;lpb;rpb;iiendb;iifakestart] ++ iistob))
))))))))
| _, (B.MacroDecl _ |B.DeclList _) -> fail
-
-and onedecl = fun allminus decla (declb, iiptvirgb, iistob) ->
+and onedecl = fun allminus decla (declb, iiptvirgb, iistob) ->
X.all_bound (A.get_inherited decla) >&&>
match A.unwrap decla, declb with
- (* kind of typedef iso, we must unfold, it's for the case
+ (* kind of typedef iso, we must unfold, it's for the case
* T { }; that we want to match against typedef struct { } xx_t;
*)
- | A.TyDecl (tya0, ptvirga),
+ | A.TyDecl (tya0, ptvirga),
({B.v_namei = Some (nameidb, None);
B.v_type = typb0;
B.v_storage = (B.StoTypedef, inl);
- B.v_local = local;
+ B.v_local = local;
B.v_attr = attrs;
B.v_type_bis = typb0bis;
}, iivirg) ->
| A.Type(cv1,tya1), ((qu,il),typb1) ->
(match A.unwrap tya1, typb1 with
- | A.StructUnionDef(tya2, lba, declsa, rba),
- (B.StructUnion (sub, sbopt, declsb), ii) ->
+ | A.StructUnionDef(tya2, lba, declsa, rba),
+ (B.StructUnion (sub, sbopt, declsb), ii) ->
- let (iisub, iisbopt, lbb, rbb) =
+ let (iisub, iisbopt, lbb, rbb) =
match sbopt with
- | None ->
+ | None ->
let (iisub, lbb, rbb) = tuple_of_list3 ii in
(iisub, [], lbb, rbb)
- | Some s ->
- pr2 (sprintf
+ | Some s ->
+ pr2 (sprintf
"warning: both a typedef (%s) and struct name introduction (%s)"
(Ast_c.str_of_name nameidb) s
);
let (iisub, iisb, lbb, rbb) = tuple_of_list4 ii in
(iisub, [iisb], lbb, rbb)
in
- let structnameb =
+ let structnameb =
structdef_to_struct_name
(Ast_c.nQ, (B.StructUnion (sub, sbopt, declsb), ii))
in
- let fake_typeb =
- Ast_c.nQ,((B.TypeName (nameidb, Some
- (Lib_parsing_c.al_type structnameb))), [])
+ let fake_typeb =
+ Ast_c.nQ,((B.TypeName (nameidb, Some
+ (Lib_parsing_c.al_type structnameb))), [])
in
- tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
- tokenf lba lbb >>= (fun lba lbb ->
- tokenf rba rbb >>= (fun rba rbb ->
+ tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
+ tokenf lba lbb >>= (fun lba lbb ->
+ tokenf rba rbb >>= (fun rba rbb ->
struct_fields (A.undots declsa) declsb >>=(fun undeclsa declsb ->
let declsa = redots declsa undeclsa in
(match A.unwrap tya2 with
- | A.Type(cv3, tya3) ->
+ | A.Type(cv3, tya3) ->
(match A.unwrap tya3 with
- | A.MetaType(ida,keep, inherited) ->
+ | A.MetaType(ida,keep, inherited) ->
- fullType tya2 fake_typeb >>= (fun tya2 fake_typeb ->
+ fullType tya2 fake_typeb >>= (fun tya2 fake_typeb ->
let tya1 =
A.StructUnionDef(tya2,lba,declsa,rba)+> A.rewrap tya1 in
let tya0 = A.Type(cv1, tya1) +> A.rewrap tya0 in
-
-
+
+
let typb1 = B.StructUnion (sub,sbopt, declsb),
[iisub] @ iisbopt @ [lbb;rbb] in
let typb0 = ((qu, il), typb1) in
-
- match fake_typeb with
- | _nQ, ((B.TypeName (nameidb, _typ)),[]) ->
+
+ match fake_typeb with
+ | _nQ, ((B.TypeName (nameidb, _typ)),[]) ->
return (
(A.TyDecl (tya0, ptvirga)) +> A.rewrap decla,
},
iivirg),iiptvirgb,iistob)
)
- | _ -> raise Impossible
+ | _ -> raise Impossible
)
- | A.StructUnionName(sua, sa) ->
+ | A.StructUnionName(sua, sa) ->
- fullType tya2 structnameb >>= (fun tya2 structnameb ->
+ fullType tya2 structnameb >>= (fun tya2 structnameb ->
let tya1 = A.StructUnionDef(tya2,lba,declsa,rba)+> A.rewrap tya1
in
let tya0 = A.Type(cv1, tya1) +> A.rewrap tya0 in
- match structnameb with
+ match structnameb with
| _nQ, (B.StructUnionName (sub, s), [iisub;iisbopt]) ->
let typb1 = B.StructUnion (sub,sbopt, declsb),
[iisub;iisbopt;lbb;rbb] in
let typb0 = ((qu, il), typb1) in
-
+
return (
(A.TyDecl (tya0, ptvirga)) +> A.rewrap decla,
(({B.v_namei = Some (nameidb, None);
},
iivirg),iiptvirgb,iistob)
)
- | _ -> raise Impossible
+ | _ -> raise Impossible
)
| _ -> raise Impossible
)
)
| _ -> fail
)
-
- | A.UnInit (stoa, typa, ida, ptvirga),
- ({B.v_namei= Some (nameidb, _);B.v_storage= (B.StoTypedef,_);}, iivirg)
+
+ | A.UnInit (stoa, typa, ida, ptvirga),
+ ({B.v_namei= Some (nameidb, _);B.v_storage= (B.StoTypedef,_);}, iivirg)
-> fail
- | A.Init (stoa, typa, ida, eqa, inia, ptvirga),
+ | A.Init (stoa, typa, ida, eqa, inia, ptvirga),
({B.v_namei=Some(nameidb, _);B.v_storage=(B.StoTypedef,_);}, iivirg)
-> fail
(* could handle iso here but handled in standard.iso *)
- | A.UnInit (stoa, typa, ida, ptvirga),
+ | A.UnInit (stoa, typa, ida, ptvirga),
({B.v_namei = Some (nameidb, None);
B.v_type = typb;
B.v_storage = stob;
B.v_local = local;
B.v_attr = attrs;
B.v_type_bis = typbbis;
- }, iivirg) ->
+ }, iivirg) ->
- tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
- fullType typa typb >>= (fun typa typb ->
- ident_cpp DontKnow ida nameidb >>= (fun ida nameidb ->
- storage_optional_allminus allminus stoa (stob, iistob) >>=
- (fun stoa (stob, iistob) ->
+ tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
+ fullType typa typb >>= (fun typa typb ->
+ ident_cpp DontKnow ida nameidb >>= (fun ida nameidb ->
+ storage_optional_allminus allminus stoa (stob, iistob) >>=
+ (fun stoa (stob, iistob) ->
return (
(A.UnInit (stoa, typa, ida, ptvirga)) +> A.rewrap decla,
(({B.v_namei = Some (nameidb, None);
iiptvirgb,iistob)
)))))
- | A.Init (stoa, typa, ida, eqa, inia, ptvirga),
+ | A.Init (stoa, typa, ida, eqa, inia, ptvirga),
({B.v_namei = Some(nameidb, Some (iieqb, inib));
B.v_type = typb;
B.v_storage = stob;
B.v_type_bis = typbbis;
},iivirg)
->
- tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
- tokenf eqa iieqb >>= (fun eqa iieqb ->
- fullType typa typb >>= (fun typa typb ->
- ident_cpp DontKnow ida nameidb >>= (fun ida nameidb ->
- storage_optional_allminus allminus stoa (stob, iistob) >>=
- (fun stoa (stob, iistob) ->
- initialiser inia inib >>= (fun inia inib ->
+ tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
+ tokenf eqa iieqb >>= (fun eqa iieqb ->
+ fullType typa typb >>= (fun typa typb ->
+ ident_cpp DontKnow ida nameidb >>= (fun ida nameidb ->
+ storage_optional_allminus allminus stoa (stob, iistob) >>=
+ (fun stoa (stob, iistob) ->
+ initialiser inia inib >>= (fun inia inib ->
return (
(A.Init (stoa, typa, ida, eqa, inia, ptvirga)) +> A.rewrap decla,
(({B.v_namei = Some(nameidb, Some (iieqb, inib));
},iivirg),
iiptvirgb,iistob)
)))))))
-
+
(* do iso-by-absence here ? allow typedecl and var ? *)
- | A.TyDecl (typa, ptvirga),
- ({B.v_namei = None; B.v_type = typb;
- B.v_storage = stob;
+ | A.TyDecl (typa, ptvirga),
+ ({B.v_namei = None; B.v_type = typb;
+ B.v_storage = stob;
B.v_local = local;
B.v_attr = attrs;
B.v_type_bis = typbbis;
if stob =*= (B.NoSto, false)
then
- tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
- fullType typa typb >>= (fun typa typb ->
+ tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
+ fullType typa typb >>= (fun typa typb ->
return (
(A.TyDecl (typa, ptvirga)) +> A.rewrap decla,
(({B.v_namei = None;
else fail
- | A.Typedef (stoa, typa, ida, ptvirga),
+ | A.Typedef (stoa, typa, ida, ptvirga),
({B.v_namei = Some (nameidb, None);
B.v_type = typb;
B.v_storage = (B.StoTypedef,inline);
B.v_type_bis = typbbis;
},iivirg) ->
- tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
- fullType typa typb >>= (fun typa typb ->
+ tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
+ fullType typa typb >>= (fun typa typb ->
(match iistob with
- | [iitypedef] ->
- tokenf stoa iitypedef >>= (fun stoa iitypedef ->
+ | [iitypedef] ->
+ tokenf stoa iitypedef >>= (fun stoa iitypedef ->
return (stoa, [iitypedef])
)
| _ -> failwith "weird, have both typedef and inline or nothing";
- ) >>= (fun stoa iistob ->
+ ) >>= (fun stoa iistob ->
(match A.unwrap ida with
- | A.MetaType(_,_,_) ->
+ | A.MetaType(_,_,_) ->
- let fake_typeb =
- Ast_c.nQ, ((B.TypeName (nameidb, Ast_c.noTypedefDef())), [])
+ let fake_typeb =
+ Ast_c.nQ, ((B.TypeName (nameidb, Ast_c.noTypedefDef())), [])
in
- fullTypebis ida fake_typeb >>= (fun ida fake_typeb ->
+ fullTypebis ida fake_typeb >>= (fun ida fake_typeb ->
match fake_typeb with
| _nQ, ((B.TypeName (nameidb, _typ)), []) ->
return (ida, nameidb)
| _ -> raise Impossible
)
- | A.TypeName sa ->
+ | A.TypeName sa ->
(match nameidb with
- | B.RegularName (sb, iidb) ->
+ | B.RegularName (sb, iidb) ->
let iidb1 = tuple_of_list1 iidb in
-
+
if (term sa) =$= sb
- then
- tokenf sa iidb1 >>= (fun sa iidb1 ->
+ then
+ tokenf sa iidb1 >>= (fun sa iidb1 ->
return (
(A.TypeName sa) +> A.rewrap ida,
B.RegularName (sb, [iidb1])
iiptvirgb, iistob)
)
))))
-
-
- | _, ({B.v_namei = None;}, _) ->
+
+
+ | _, ({B.v_namei = None;}, _) ->
(* old: failwith "no variable in this declaration, weird" *)
fail
- | A.DisjDecl declas, declb ->
- declas +> List.fold_left (fun acc decla ->
- acc >|+|>
+ | A.DisjDecl declas, declb ->
+ declas +> List.fold_left (fun acc decla ->
+ acc >|+|>
(* (declaration (mckstart, allminus, decla) declb) *)
(onedecl allminus decla (declb,iiptvirgb, iistob))
) fail
-
+
(* only in struct type decls *)
| A.Ddots(dots,whencode), _ ->
raise Impossible
-
- | A.OptDecl _, _ | A.UniqueDecl _, _ ->
+
+ | A.OptDecl _, _ | A.UniqueDecl _, _ ->
failwith "not handling Opt/Unique Decl"
- | _, ({B.v_namei=Some _}, _) ->
+ | _, ({B.v_namei=Some _}, _) ->
fail
(* ------------------------------------------------------------------------- *)
-and (initialiser: (A.initialiser, Ast_c.initialiser) matcher) = fun ia ib ->
+and (initialiser: (A.initialiser, Ast_c.initialiser) matcher) = fun ia ib ->
X.all_bound (A.get_inherited ia) >&&>
match (A.unwrap ia,ib) with
- | (A.MetaInit(ida,keep,inherited), ib) ->
+ | (A.MetaInit(ida,keep,inherited), ib) ->
let max_min _ =
Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_ini ib) in
X.envf keep inherited (ida, Ast_c.MetaInitVal ib, max_min)
- (fun () ->
- X.distrf_ini ida ib >>= (fun ida ib ->
+ (fun () ->
+ X.distrf_ini ida ib >>= (fun ida ib ->
return (
A.MetaInit (ida,keep,inherited) +> A.rewrap ia,
ib
))
)
- | (A.InitExpr expa, ib) ->
+ | (A.InitExpr expa, ib) ->
(match A.unwrap expa, ib with
- | A.Edots (mcode, None), ib ->
- X.distrf_ini (dots2metavar mcode) ib >>= (fun mcode ib ->
+ | A.Edots (mcode, None), ib ->
+ X.distrf_ini (dots2metavar mcode) ib >>= (fun mcode ib ->
return (
- A.InitExpr
- (A.Edots (metavar2dots mcode, None) +> A.rewrap expa)
+ A.InitExpr
+ (A.Edots (metavar2dots mcode, None) +> A.rewrap expa)
+> A.rewrap ia,
ib
))
| A.Edots (_, Some expr), _ -> failwith "not handling when on Edots"
- | _, (B.InitExpr expb, ii) ->
+ | _, (B.InitExpr expb, ii) ->
assert (null ii);
- expression expa expb >>= (fun expa expb ->
+ expression expa expb >>= (fun expa expb ->
return (
(A.InitExpr expa) +> A.rewrap ia,
(B.InitExpr expb, ii)
| _ -> fail
)
- | (A.InitList (ia1, ias, ia2, []), (B.InitList ibs, ii)) ->
- (match ii with
- | ib1::ib2::iicommaopt ->
+ | (A.InitList (ia1, ias, ia2, []), (B.InitList ibs, ii)) ->
+ (match ii with
+ | ib1::ib2::iicommaopt ->
tokenf ia1 ib1 >>= (fun ia1 ib1 ->
tokenf ia2 ib2 >>= (fun ia2 ib2 ->
initialisers ias (ibs, iicommaopt) >>= (fun ias (ibs,iicommaopt) ->
(A.InitList (ia1, ias, ia2, [])) +> A.rewrap ia,
(B.InitList ibs, ib1::ib2::iicommaopt)
))))
-
+
| _ -> raise Impossible
)
failwith "TODO: not handling whencode in initialisers"
- | (A.InitGccExt (designatorsa, ia2, inia),
+ | (A.InitGccExt (designatorsa, ia2, inia),
(B.InitDesignators (designatorsb, inib), ii2))->
let iieq = tuple_of_list1 ii2 in
- tokenf ia2 iieq >>= (fun ia2 iieq ->
+ tokenf ia2 iieq >>= (fun ia2 iieq ->
designators designatorsa designatorsb >>=
(fun designatorsa designatorsb ->
- initialiser inia inib >>= (fun inia inib ->
+ initialiser inia inib >>= (fun inia inib ->
return (
(A.InitGccExt (designatorsa, ia2, inia)) +> A.rewrap ia,
(B.InitDesignators (designatorsb, inib), [iieq])
- | (A.InitGccName (ida, ia1, inia), (B.InitFieldOld (idb, inib), ii)) ->
- (match ii with
- | [iidb;iicolon] ->
- ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
- initialiser inia inib >>= (fun inia inib ->
- tokenf ia1 iicolon >>= (fun ia1 iicolon ->
+ | (A.InitGccName (ida, ia1, inia), (B.InitFieldOld (idb, inib), ii)) ->
+ (match ii with
+ | [iidb;iicolon] ->
+ ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
+ initialiser inia inib >>= (fun inia inib ->
+ tokenf ia1 iicolon >>= (fun ia1 iicolon ->
return (
(A.InitGccName (ida, ia1, inia)) +> A.rewrap ia,
(B.InitFieldOld (idb, inib), [iidb;iicolon])
| A.IComma(comma), _ ->
raise Impossible
- | A.UniqueIni _,_ | A.OptIni _,_ ->
+ | A.UniqueIni _,_ | A.OptIni _,_ ->
failwith "not handling Opt/Unique on initialisers"
- | _, (B.InitIndexOld (_, _), _) -> fail
- | _, (B.InitFieldOld (_, _), _) -> fail
+ | _, (B.InitIndexOld (_, _), _) -> fail
+ | _, (B.InitFieldOld (_, _), _) -> fail
| _, ((B.InitDesignators (_, _)|B.InitList _|B.InitExpr _), _)
-> fail
(A.DesignatorField (ia1, ida), (B.DesignatorField idb,ii1)) ->
let (iidot, iidb) = tuple_of_list2 ii1 in
- tokenf ia1 iidot >>= (fun ia1 iidot ->
+ tokenf ia1 iidot >>= (fun ia1 iidot ->
ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
return (
A.DesignatorField (ia1, ida),
)))
| (A.DesignatorIndex (ia1,ea,ia2), (B.DesignatorIndex eb, ii1)) ->
-
+
let (ib1, ib2) = tuple_of_list2 ii1 in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- expression ea eb >>= (fun ea eb ->
+ tokenf ia1 ib1 >>= (fun ia1 ib1 ->
+ tokenf ia2 ib2 >>= (fun ia2 ib2 ->
+ expression ea eb >>= (fun ea eb ->
return (
A.DesignatorIndex (ia1,ea,ia2),
(B.DesignatorIndex eb, [ib1;ib2])
(B.DesignatorRange (e1b, e2b), ii1)) ->
let (ib1, ib2, ib3) = tuple_of_list3 ii1 in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
- expression e1a e1b >>= (fun e1a e1b ->
- expression e2a e2b >>= (fun e2a e2b ->
+ tokenf ia1 ib1 >>= (fun ia1 ib1 ->
+ tokenf ia2 ib2 >>= (fun ia2 ib2 ->
+ tokenf ia3 ib3 >>= (fun ia3 ib3 ->
+ expression e1a e1b >>= (fun e1a e1b ->
+ expression e2a e2b >>= (fun e2a e2b ->
return (
A.DesignatorRange (ia1,e1a,ia2,e2a,ia3),
(B.DesignatorRange (e1b, e2b), [ib1;ib2;ib3])
let ias_unsplit = unsplit_icomma ias in
let ibs_split = resplit_initialiser ibs iicomma in
- let f =
- if need_unordered_initialisers ibs
+ let f =
+ if need_unordered_initialisers ibs
then initialisers_unordered2
else initialisers_ordered2
in
- f ias_unsplit ibs_split >>=
- (fun ias_unsplit ibs_split ->
+ f ias_unsplit ibs_split >>=
+ (fun ias_unsplit ibs_split ->
return (
split_icomma ias_unsplit,
unsplit_initialiser ibs_split
)
(* todo: one day julia will reput a IDots *)
-and initialisers_ordered2 = fun ias ibs ->
+and initialisers_ordered2 = fun ias ibs ->
match ias, ibs with
| [], [] -> return ([], [])
- | (x, xcomma)::xs, (y, commay)::ys ->
+ | (x, xcomma)::xs, (y, commay)::ys ->
(match A.unwrap xcomma with
- | A.IComma commax ->
- tokenf commax commay >>= (fun commax commay ->
- initialiser x y >>= (fun x y ->
- initialisers_ordered2 xs ys >>= (fun xs ys ->
+ | A.IComma commax ->
+ tokenf commax commay >>= (fun commax commay ->
+ initialiser x y >>= (fun x y ->
+ initialisers_ordered2 xs ys >>= (fun xs ys ->
return (
- (x, (A.IComma commax) +> A.rewrap xcomma)::xs,
+ (x, (A.IComma commax) +> A.rewrap xcomma)::xs,
(y, commay)::ys
)
)))
)
| _ -> fail
-
-and initialisers_unordered2 = fun ias ibs ->
+
+and initialisers_unordered2 = fun ias ibs ->
match ias, ibs with
| [], ys -> return ([], ys)
- | (x,xcomma)::xs, ys ->
+ | (x,xcomma)::xs, ys ->
let permut = Common.uncons_permut_lazy ys in
- permut +> List.fold_left (fun acc ((e, pos), rest) ->
- acc >||>
+ permut +> List.fold_left (fun acc ((e, pos), rest) ->
+ acc >||>
(
- (match A.unwrap xcomma, e with
- | A.IComma commax, (y, commay) ->
- tokenf commax commay >>= (fun commax commay ->
- initialiser x y >>= (fun x y ->
+ (match A.unwrap xcomma, e with
+ | A.IComma commax, (y, commay) ->
+ tokenf commax commay >>= (fun commax commay ->
+ initialiser x y >>= (fun x y ->
return (
- (x, (A.IComma commax) +> A.rewrap xcomma),
+ (x, (A.IComma commax) +> A.rewrap xcomma),
(y, commay))
)
)
| _ -> raise Impossible (* unsplit_iicomma wrong *)
- )
- >>= (fun x e ->
+ )
+ >>= (fun x e ->
let rest = Lazy.force rest in
- initialisers_unordered2 xs rest >>= (fun xs rest ->
+ initialisers_unordered2 xs rest >>= (fun xs rest ->
return (
x::xs,
Common.insert_elem_pos (e, pos) rest
))))
) fail
-
+
(* ------------------------------------------------------------------------- *)
and (struct_fields: (A.declaration list, B.field list) matcher) =
- fun eas ebs ->
+ fun eas ebs ->
match eas, ebs with
| [], [] -> return ([], [])
| [], eb::ebs -> fail
- | ea::eas, ebs ->
+ | ea::eas, ebs ->
X.all_bound (A.get_inherited ea) >&&>
(match A.unwrap ea, ebs with
- | A.Ddots (mcode, optwhen), ys ->
+ | A.Ddots (mcode, optwhen), ys ->
if optwhen <> None then failwith "not handling when in argument";
(* '...' can take more or less the beginnings of the arguments *)
- let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
- startendxs +> List.fold_left (fun acc (startxs, endxs) ->
+ let startendxs =
+ if eas = []
+ then [(ys,[])] (* hack! the only one that can work *)
+ else Common.zip (Common.inits ys) (Common.tails ys) in
+ startendxs +> List.fold_left (fun acc (startxs, endxs) ->
acc >||> (
-
- (if null startxs
+
+ (if null startxs
then
if mcode_contain_plus (mcodekind mcode)
- then fail
+ then fail
(* failwith "I have no token that I could accroche myself on" *)
else return (dots2metavar mcode, [])
- else
+ else
X.distrf_struct_fields (dots2metavar mcode) startxs
) >>= (fun mcode startxs ->
let mcode = metavar2dots mcode in
- struct_fields eas endxs >>= (fun eas endxs ->
+ struct_fields eas endxs >>= (fun eas endxs ->
return (
(A.Ddots (mcode, optwhen) +> A.rewrap ea) ::eas,
startxs ++ endxs
)))
)
- ) fail
- | _unwrapx, eb::ebs ->
- struct_field ea eb >>= (fun ea eb ->
- struct_fields eas ebs >>= (fun eas ebs ->
+ ) fail
+ | _unwrapx, eb::ebs ->
+ struct_field ea eb >>= (fun ea eb ->
+ struct_fields eas ebs >>= (fun eas ebs ->
return (ea::eas, eb::ebs)
))
| _unwrapx, [] -> fail
)
-and (struct_field: (A.declaration, B.field) matcher) = fun fa fb ->
+and (struct_field: (A.declaration, B.field) matcher) = fun fa fb ->
- match fb with
- | B.DeclarationField (B.FieldDeclList (onefield_multivars,iiptvirg)) ->
+ match fb with
+ | B.DeclarationField (B.FieldDeclList (onefield_multivars,iiptvirg)) ->
let iiptvirgb = tuple_of_list1 iiptvirg in
(match onefield_multivars with
| [] -> raise Impossible
- | [onevar,iivirg] ->
+ | [onevar,iivirg] ->
assert (null iivirg);
(match onevar with
- | B.BitField (sopt, typb, _, expr) ->
+ | B.BitField (sopt, typb, _, expr) ->
pr2_once "warning: bitfield not handled by ast_cocci";
fail
- | B.Simple (None, typb) ->
+ | B.Simple (None, typb) ->
pr2_once "warning: unamed struct field not handled by ast_cocci";
fail
- | B.Simple (Some nameidb, typb) ->
+ | B.Simple (Some nameidb, typb) ->
(* build a declaration from a struct field *)
let allminus = false in
let iisto = [] in
let stob = B.NoSto, false in
- let fake_var =
+ let fake_var =
({B.v_namei = Some (nameidb, None);
B.v_type = typb;
B.v_storage = stob;
B.v_local = Ast_c.NotLocalDecl;
B.v_attr = Ast_c.noattr;
- B.v_type_bis = ref None;
+ B.v_type_bis = ref None;
(* the struct field should also get expanded ? no it's not
* important here, we will rematch very soon *)
},
- iivirg)
+ iivirg)
in
- onedecl allminus fa (fake_var,iiptvirgb,iisto) >>=
- (fun fa (var,iiptvirgb,iisto) ->
+ onedecl allminus fa (fake_var,iiptvirgb,iisto) >>=
+ (fun fa (var,iiptvirgb,iisto) ->
match fake_var with
| ({B.v_namei = Some (nameidb, None);
B.v_type = typb;
B.v_storage = stob;
- }, iivirg) ->
+ }, iivirg) ->
let onevar = B.Simple (Some nameidb, typb) in
-
+
return (
(fa),
- ((B.DeclarationField
+ ((B.DeclarationField
(B.FieldDeclList ([onevar, iivirg], [iiptvirgb])))
)
)
)
)
- | x::y::xs ->
+ | x::y::xs ->
pr2_once "PB: More that one variable in decl. Have to split";
fail
)
- | B.EmptyField _iifield ->
+ | B.EmptyField _iifield ->
fail
- | B.MacroDeclField _ ->
- raise Todo
+ | B.MacroDeclField ((sb,ebs),ii) ->
+ (match A.unwrap fa with
+ A.MacroDecl (sa,lpa,eas,rpa,enda) -> raise Todo
+ | _ -> fail)
| B.CppDirectiveStruct directive -> fail
| B.IfdefStruct directive -> fail
(* ------------------------------------------------------------------------- *)
-and (fullType: (A.fullType, Ast_c.fullType) matcher) =
- fun typa typb ->
- X.optional_qualifier_flag (fun optional_qualifier ->
+and (fullType: (A.fullType, Ast_c.fullType) matcher) =
+ fun typa typb ->
+ X.optional_qualifier_flag (fun optional_qualifier ->
X.all_bound (A.get_inherited typa) >&&>
match A.unwrap typa, typb with
| A.Type(cv,ty1), ((qu,il),ty2) ->
- if qu.B.const && qu.B.volatile
+ if qu.B.const && qu.B.volatile
then
pr2_once
- ("warning: the type is both const & volatile but cocci " ^
+ ("warning: the type is both const & volatile but cocci " ^
"does not handle that");
(* Drop out the const/volatile part that has been matched.
* later in match_t_t when we encounter a T, we must not add in
* the environment the whole type.
*)
-
+
(match cv with
(* "iso-by-absence" *)
- | None ->
- let do_stuff () =
- fullTypebis ty1 ((qu,il), ty2) >>= (fun ty1 fullty2 ->
+ | None ->
+ let do_stuff () =
+ fullTypebis ty1 ((qu,il), ty2) >>= (fun ty1 fullty2 ->
return (
(A.Type(None, ty1)) +> A.rewrap typa,
fullty2
| false, false -> do_stuff ()
| false, true -> fail
| true, false -> do_stuff ()
- | true, true ->
- if !Flag.show_misc
+ | true, true ->
+ if !Flag.show_misc
then pr2_once "USING optional_qualifier builtin isomorphism";
do_stuff()
)
-
-
- | Some x ->
- (* todo: can be __const__ ? can be const & volatile so
- * should filter instead ?
+
+
+ | Some x ->
+ (* todo: can be __const__ ? can be const & volatile so
+ * should filter instead ?
*)
- (match term x, il with
- | A.Const, [i1] when qu.B.const ->
-
- tokenf x i1 >>= (fun x i1 ->
- fullTypebis ty1 (Ast_c.nQ,ty2) >>= (fun ty1 (_, ty2) ->
+ (match term x, il with
+ | A.Const, [i1] when qu.B.const ->
+
+ tokenf x i1 >>= (fun x i1 ->
+ fullTypebis ty1 (Ast_c.nQ,ty2) >>= (fun ty1 (_, ty2) ->
return (
(A.Type(Some x, ty1)) +> A.rewrap typa,
((qu, [i1]), ty2)
)))
-
- | A.Volatile, [i1] when qu.B.volatile ->
- tokenf x i1 >>= (fun x i1 ->
- fullTypebis ty1 (Ast_c.nQ,ty2) >>= (fun ty1 (_, ty2) ->
+
+ | A.Volatile, [i1] when qu.B.volatile ->
+ tokenf x i1 >>= (fun x i1 ->
+ fullTypebis ty1 (Ast_c.nQ,ty2) >>= (fun ty1 (_, ty2) ->
return (
(A.Type(Some x, ty1)) +> A.rewrap typa,
((qu, [i1]), ty2)
)))
-
+
| _ -> fail
)
)
- | A.DisjType typas, typb ->
+ | A.DisjType typas, typb ->
typas +>
List.fold_left (fun acc typa -> acc >|+|> (fullType typa typb)) fail
| A.OptType(_), _ | A.UniqueType(_), _
-> failwith "not handling Opt/Unique on type"
)
-
+
(*
* Why not (A.typeC, Ast_c.typeC) matcher ?
- * because when there is MetaType, we want that T record the whole type,
+ * because when there is MetaType, we want that T record the whole type,
* including the qualifier, and so this type (and the new_il function in
* preceding function).
*)
-and (fullTypebis: (A.typeC, Ast_c.fullType) matcher) =
- fun ta tb ->
- X.all_bound (A.get_inherited ta) >&&>
+and (fullTypebis: (A.typeC, Ast_c.fullType) matcher) =
+ fun ta tb ->
+ X.all_bound (A.get_inherited ta) >&&>
match A.unwrap ta, tb with
(* cas general *)
- | A.MetaType(ida,keep, inherited), typb ->
+ | A.MetaType(ida,keep, inherited), typb ->
let max_min _ =
Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_type typb) in
- X.envf keep inherited (ida, B.MetaTypeVal typb, max_min) (fun () ->
- X.distrf_type ida typb >>= (fun ida typb ->
+ X.envf keep inherited (ida, B.MetaTypeVal typb, max_min) (fun () ->
+ X.distrf_type ida typb >>= (fun ida typb ->
return (
A.MetaType(ida,keep, inherited) +> A.rewrap ta,
typb
))
)
- | unwrap, (qub, typb) ->
- typeC ta typb >>= (fun ta typb ->
+ | unwrap, (qub, typb) ->
+ typeC ta typb >>= (fun ta typb ->
return (ta, (qub, typb))
)
(* In ii there is a list, sometimes of length 1 or 2 or 3.
* And even if in baseb we have a Signed Int, that does not mean
* that ii is of length 2, cos Signed is the default, so if in signa
- * we have Signed explicitely ? we cant "accrocher" this mcode to
+ * we have Signed explicitely ? we cant "accrocher" this mcode to
* something :( So for the moment when there is signed in cocci,
* we force that there is a signed in c too (done in pattern.ml).
*)
let signbopt, iibaseb = split_signb_baseb_ii (baseb, ii) in
-
+
(* handle some iso on type ? (cf complex C rule for possible implicit
casting) *)
match basea, baseb with
- | A.VoidType, B.Void
+ | A.VoidType, B.Void
| A.FloatType, B.FloatType (B.CFloat)
- | A.DoubleType, B.FloatType (B.CDouble) ->
- assert (signaopt =*= None);
+ | A.DoubleType, B.FloatType (B.CDouble) ->
+ assert (signaopt =*= None);
let stringa = tuple_of_list1 stringsa in
- let (ibaseb) = tuple_of_list1 ii in
- tokenf stringa ibaseb >>= (fun stringa ibaseb ->
+ let (ibaseb) = tuple_of_list1 ii in
+ tokenf stringa ibaseb >>= (fun stringa ibaseb ->
return (
(rebuilda ([stringa], signaopt)) +> A.rewrap ta,
(B.BaseType baseb, [ibaseb])
))
-
- | A.CharType, B.IntType B.CChar when signaopt =*= None ->
+
+ | A.CharType, B.IntType B.CChar when signaopt =*= None ->
let stringa = tuple_of_list1 stringsa in
let ibaseb = tuple_of_list1 ii in
- tokenf stringa ibaseb >>= (fun stringa ibaseb ->
+ tokenf stringa ibaseb >>= (fun stringa ibaseb ->
return (
(rebuilda ([stringa], signaopt)) +> A.rewrap ta,
(B.BaseType (B.IntType B.CChar), [ibaseb])
))
-
- | A.CharType,B.IntType (B.Si (_sign, B.CChar2)) when signaopt <> None ->
+
+ | A.CharType,B.IntType (B.Si (_sign, B.CChar2)) when signaopt <> None ->
let stringa = tuple_of_list1 stringsa in
let ibaseb = tuple_of_list1 iibaseb in
- sign signaopt signbopt >>= (fun signaopt iisignbopt ->
- tokenf stringa ibaseb >>= (fun stringa ibaseb ->
+ sign signaopt signbopt >>= (fun signaopt iisignbopt ->
+ tokenf stringa ibaseb >>= (fun stringa ibaseb ->
return (
(rebuilda ([stringa], signaopt)) +> A.rewrap ta,
(B.BaseType (baseb), iisignbopt ++ [ibaseb])
)))
-
- | A.ShortType, B.IntType (B.Si (_, B.CShort))
- | A.IntType, B.IntType (B.Si (_, B.CInt))
+
+ | A.ShortType, B.IntType (B.Si (_, B.CShort))
+ | A.IntType, B.IntType (B.Si (_, B.CInt))
| A.LongType, B.IntType (B.Si (_, B.CLong)) ->
let stringa = tuple_of_list1 stringsa in
- (match iibaseb with
- | [] ->
+ (match iibaseb with
+ | [] ->
(* iso-by-presence ? *)
(* when unsigned int in SP, allow have just unsigned in C ? *)
if mcode_contain_plus (mcodekind stringa)
then fail
- else
-
- sign signaopt signbopt >>= (fun signaopt iisignbopt ->
+ else
+
+ sign signaopt signbopt >>= (fun signaopt iisignbopt ->
return (
(rebuilda ([stringa], signaopt)) +> A.rewrap ta,
(B.BaseType (baseb), iisignbopt ++ [])
))
-
- | [x;y] ->
- pr2_once
+
+ | [x;y] ->
+ pr2_once
"warning: long int or short int not handled by ast_cocci";
fail
- | [ibaseb] ->
- sign signaopt signbopt >>= (fun signaopt iisignbopt ->
- tokenf stringa ibaseb >>= (fun stringa ibaseb ->
+ | [ibaseb] ->
+ sign signaopt signbopt >>= (fun signaopt iisignbopt ->
+ tokenf stringa ibaseb >>= (fun stringa ibaseb ->
return (
(rebuilda ([stringa], signaopt)) +> A.rewrap ta,
(B.BaseType (baseb), iisignbopt ++ [ibaseb])
)
-
+
| A.LongLongType, B.IntType (B.Si (_, B.CLongLong)) ->
let (string1a,string2a) = tuple_of_list2 stringsa in
- (match iibaseb with
- [ibase1b;ibase2b] ->
- sign signaopt signbopt >>= (fun signaopt iisignbopt ->
- tokenf string1a ibase1b >>= (fun base1a ibase1b ->
- tokenf string2a ibase2b >>= (fun base2a ibase2b ->
+ (match iibaseb with
+ [ibase1b;ibase2b] ->
+ sign signaopt signbopt >>= (fun signaopt iisignbopt ->
+ tokenf string1a ibase1b >>= (fun base1a ibase1b ->
+ tokenf string2a ibase2b >>= (fun base2a ibase2b ->
return (
(rebuilda ([base1a;base2a], signaopt)) +> A.rewrap ta,
(B.BaseType (baseb), iisignbopt ++ [ibase1b;ibase2b])
| _ -> raise Impossible)
- | _, B.FloatType B.CLongDouble
- ->
- pr2_once
+ | _, B.FloatType B.CLongDouble
+ ->
+ pr2_once
"warning: long double not handled by ast_cocci";
fail
(* In ii there is a list, sometimes of length 1 or 2 or 3.
* And even if in baseb we have a Signed Int, that does not mean
* that ii is of length 2, cos Signed is the default, so if in signa
- * we have Signed explicitely ? we cant "accrocher" this mcode to
+ * we have Signed explicitely ? we cant "accrocher" this mcode to
* something :( So for the moment when there is signed in cocci,
* we force that there is a signed in c too (done in pattern.ml).
*)
let signbopt, iibaseb = split_signb_baseb_ii (baseb, ii) in
- let match_to_type rebaseb =
- sign signaopt signbopt >>= (fun signaopt iisignbopt ->
+ let match_to_type rebaseb =
+ sign signaopt signbopt >>= (fun signaopt iisignbopt ->
let fta = A.rewrap basea (A.Type(None,basea)) in
let ftb = Ast_c.nQ,(B.BaseType (rebaseb), iibaseb) in
fullType fta ftb >>= (fun fta (_,tb) ->
(B.BaseType (baseb), iisignbopt ++ ii)
)
| _ -> failwith "not possible"))) in
-
+
(* handle some iso on type ? (cf complex C rule for possible implicit
casting) *)
match baseb with
| B.IntType (B.Si (_sign, B.CChar2)) ->
match_to_type (B.IntType B.CChar)
-
+
| B.IntType (B.Si (_, ty)) ->
- (match iibaseb with
+ (match iibaseb with
| [] -> fail (* metavariable has to match something *)
| _ -> match_to_type (B.IntType (B.Si (B.Signed, ty)))
| (B.Void|B.FloatType _|B.IntType _) -> fail
-and (typeC: (A.typeC, Ast_c.typeC) matcher) =
- fun ta tb ->
+and (typeC: (A.typeC, Ast_c.typeC) matcher) =
+ fun ta tb ->
match A.unwrap ta, tb with
- | A.BaseType (basea,stringsa), (B.BaseType baseb, ii) ->
+ | A.BaseType (basea,stringsa), (B.BaseType baseb, ii) ->
simulate_signed ta basea stringsa None tb baseb ii
(function (stringsa, signaopt) -> A.BaseType (basea,stringsa))
- | A.SignedT (signaopt, Some basea), (B.BaseType baseb, ii) ->
+ | A.SignedT (signaopt, Some basea), (B.BaseType baseb, ii) ->
(match A.unwrap basea with
A.BaseType (basea1,strings1) ->
simulate_signed ta basea1 strings1 (Some signaopt) tb baseb ii
A.SignedT(signaopt,Some basea)
| _ -> failwith "not possible")
| _ -> failwith "not possible")
- | A.SignedT (signa,None), (B.BaseType baseb, ii) ->
+ | A.SignedT (signa,None), (B.BaseType baseb, ii) ->
let signbopt, iibaseb = split_signb_baseb_ii (baseb, ii) in
(match iibaseb, baseb with
- | [], B.IntType (B.Si (_sign, B.CInt)) ->
- sign (Some signa) signbopt >>= (fun signaopt iisignbopt ->
+ | [], B.IntType (B.Si (_sign, B.CInt)) ->
+ sign (Some signa) signbopt >>= (fun signaopt iisignbopt ->
match signaopt with
| None -> raise Impossible
- | Some signa ->
+ | Some signa ->
return (
(A.SignedT (signa,None)) +> A.rewrap ta,
(B.BaseType baseb, iisignbopt)
(* todo? iso with array *)
- | A.Pointer (typa, iamult), (B.Pointer typb, ii) ->
- let (ibmult) = tuple_of_list1 ii in
- fullType typa typb >>= (fun typa typb ->
- tokenf iamult ibmult >>= (fun iamult ibmult ->
+ | A.Pointer (typa, iamult), (B.Pointer typb, ii) ->
+ let (ibmult) = tuple_of_list1 ii in
+ fullType typa typb >>= (fun typa typb ->
+ tokenf iamult ibmult >>= (fun iamult ibmult ->
return (
(A.Pointer (typa, iamult)) +> A.rewrap ta,
(B.Pointer typb, [ibmult])
)))
- | A.FunctionType(allminus,tyaopt,lpa,paramsa,rpa),
- (B.FunctionType(tyb, (paramsb, (isvaargs, iidotsb))), ii) ->
+ | A.FunctionType(allminus,tyaopt,lpa,paramsa,rpa),
+ (B.FunctionType(tyb, (paramsb, (isvaargs, iidotsb))), ii) ->
let (lpb, rpb) = tuple_of_list2 ii in
- if isvaargs
+ if isvaargs
then
pr2_once
("Not handling well variable length arguments func. "^
"You have been warned");
- tokenf lpa lpb >>= (fun lpa lpb ->
- tokenf rpa rpb >>= (fun rpa rpb ->
- fullType_optional_allminus allminus tyaopt tyb >>= (fun tyaopt tyb ->
+ tokenf lpa lpb >>= (fun lpa lpb ->
+ tokenf rpa rpb >>= (fun rpa rpb ->
+ fullType_optional_allminus allminus tyaopt tyb >>= (fun tyaopt tyb ->
parameters (seqstyle paramsa) (A.undots paramsa) paramsb >>=
- (fun paramsaundots paramsb ->
+ (fun paramsaundots paramsb ->
let paramsa = redots paramsa paramsaundots in
return (
(A.FunctionType(allminus,tyaopt,lpa,paramsa,rpa) +> A.rewrap ta,
(B.FunctionType(tyb, (paramsb, (isvaargs, iidotsb))), [lpb;rpb])
)
)))))
-
-
-
- | A.FunctionPointer(tya,lp1a,stara,rp1a,lp2a,paramsa,rp2a),
+
+
+
+ | A.FunctionPointer(tya,lp1a,stara,rp1a,lp2a,paramsa,rp2a),
(B.ParenType t1, ii) ->
let (lp1b, rp1b) = tuple_of_list2 ii in
let (qu1b, t1b) = t1 in
(match t1b with
- | B.Pointer t2, ii ->
+ | B.Pointer t2, ii ->
let (starb) = tuple_of_list1 ii in
let (qu2b, t2b) = t2 in
(match t2b with
- | B.FunctionType (tyb, (paramsb, (isvaargs, iidotsb))), ii ->
+ | B.FunctionType (tyb, (paramsb, (isvaargs, iidotsb))), ii ->
let (lp2b, rp2b) = tuple_of_list2 ii in
if isvaargs
("Not handling well variable length arguments func. "^
"You have been warned");
- fullType tya tyb >>= (fun tya tyb ->
- tokenf lp1a lp1b >>= (fun lp1a lp1b ->
- tokenf rp1a rp1b >>= (fun rp1a rp1b ->
- tokenf lp2a lp2b >>= (fun lp2a lp2b ->
- tokenf rp2a rp2b >>= (fun rp2a rp2b ->
- tokenf stara starb >>= (fun stara starb ->
+ fullType tya tyb >>= (fun tya tyb ->
+ tokenf lp1a lp1b >>= (fun lp1a lp1b ->
+ tokenf rp1a rp1b >>= (fun rp1a rp1b ->
+ tokenf lp2a lp2b >>= (fun lp2a lp2b ->
+ tokenf rp2a rp2b >>= (fun rp2a rp2b ->
+ tokenf stara starb >>= (fun stara starb ->
parameters (seqstyle paramsa) (A.undots paramsa) paramsb >>=
- (fun paramsaundots paramsb ->
+ (fun paramsaundots paramsb ->
let paramsa = redots paramsa paramsaundots in
- let t2 =
- (qu2b,
+ let t2 =
+ (qu2b,
(B.FunctionType (tyb, (paramsb, (isvaargs, iidotsb))),
- [lp2b;rp2b]))
+ [lp2b;rp2b]))
in
- let t1 =
+ let t1 =
(qu1b,
(B.Pointer t2, [starb]))
in
-
+
return (
(A.FunctionPointer(tya,lp1a,stara,rp1a,lp2a,paramsa,rp2a))
+> A.rewrap ta,
)
| _ -> fail
)
-
-
+
+
(* todo: handle the iso on optionnal size specifification ? *)
- | A.Array (typa, ia1, eaopt, ia2), (B.Array (ebopt, typb), ii) ->
+ | A.Array (typa, ia1, eaopt, ia2), (B.Array (ebopt, typb), ii) ->
let (ib1, ib2) = tuple_of_list2 ii in
- fullType typa typb >>= (fun typa typb ->
- option expression eaopt ebopt >>= (fun eaopt ebopt ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
+ fullType typa typb >>= (fun typa typb ->
+ option expression eaopt ebopt >>= (fun eaopt ebopt ->
+ tokenf ia1 ib1 >>= (fun ia1 ib1 ->
+ tokenf ia2 ib2 >>= (fun ia2 ib2 ->
return (
(A.Array (typa, ia1, eaopt, ia2)) +> A.rewrap ta,
(B.Array (ebopt, typb), [ib1;ib2])
a definition. In this case, the name field is always present.
This case is also called from the case for A.StructUnionDef when
a name is present in the C code. *)
- | A.StructUnionName(sua, Some sa), (B.StructUnionName (sub, sb), ii) ->
+ | A.StructUnionName(sua, Some sa), (B.StructUnionName (sub, sb), ii) ->
(* sa is now an ident, not an mcode, old: ... && (term sa) =$= sb *)
let (ib1, ib2) = tuple_of_list2 ii in
- if equal_structUnion (term sua) sub
+ if equal_structUnion (term sua) sub
then
- ident DontKnow sa (sb, ib2) >>= (fun sa (sb, ib2) ->
- tokenf sua ib1 >>= (fun sua ib1 ->
+ ident DontKnow sa (sb, ib2) >>= (fun sa (sb, ib2) ->
+ tokenf sua ib1 >>= (fun sua ib1 ->
return (
(A.StructUnionName (sua, Some sa)) +> A.rewrap ta,
(B.StructUnionName (sub, sb), [ib1;ib2])
)))
else fail
-
- | A.StructUnionDef(ty, lba, declsa, rba),
- (B.StructUnion (sub, sbopt, declsb), ii) ->
+
+ | A.StructUnionDef(ty, lba, declsa, rba),
+ (B.StructUnion (sub, sbopt, declsb), ii) ->
let (ii_sub_sb, lbb, rbb) =
match ii with
List.fold_left (fun acc disj -> acc >|+|> (loop disj)) fail
| _ -> fail in
loop ty
-
+
| (Some sb,Common.Right (iisub,iisb)) ->
(* build a StructUnionName from a StructUnion *)
let fake_su = B.nQ, (B.StructUnionName (sub, sb), [iisub;iisb]) in
-
- fullType ty fake_su >>= (fun ty fake_su ->
+
+ fullType ty fake_su >>= (fun ty fake_su ->
match fake_su with
- | _nQ, (B.StructUnionName (sub, sb), [iisub;iisb]) ->
+ | _nQ, (B.StructUnionName (sub, sb), [iisub;iisb]) ->
return (ty, [iisub; iisb])
| _ -> raise Impossible)
| _ -> fail in
process_type
- >>= (fun ty ii_sub_sb ->
+ >>= (fun ty ii_sub_sb ->
- tokenf lba lbb >>= (fun lba lbb ->
- tokenf rba rbb >>= (fun rba rbb ->
+ tokenf lba lbb >>= (fun lba lbb ->
+ tokenf rba rbb >>= (fun rba rbb ->
struct_fields (A.undots declsa) declsb >>=(fun undeclsa declsb ->
let declsa = redots declsa undeclsa in
)))))
- (* todo? handle isomorphisms ? because Unsigned Int can be match on a
+ (* todo? handle isomorphisms ? because Unsigned Int can be match on a
* uint in the C code. But some CEs consists in renaming some types,
- * so we don't want apply isomorphisms every time.
- *)
+ * so we don't want apply isomorphisms every time.
+ *)
| A.TypeName sa, (B.TypeName (nameb, typb), noii) ->
assert (null noii);
(match nameb with
- | B.RegularName (sb, iidb) ->
+ | B.RegularName (sb, iidb) ->
let iidb1 = tuple_of_list1 iidb in
-
+
if (term sa) =$= sb
- then
- tokenf sa iidb1 >>= (fun sa iidb1 ->
+ then
+ tokenf sa iidb1 >>= (fun sa iidb1 ->
return (
(A.TypeName sa) +> A.rewrap ta,
(B.TypeName (B.RegularName (sb, [iidb1]), typb), noii)
| _, (B.ParenType e, ii) -> fail (* todo ?*)
| A.EnumName(en,namea), (B.EnumName nameb, ii) ->
let (ib1,ib2) = tuple_of_list2 ii in
- ident DontKnow namea (nameb, ib2) >>= (fun namea (nameb, ib2) ->
- tokenf en ib1 >>= (fun en ib1 ->
+ ident DontKnow namea (nameb, ib2) >>= (fun namea (nameb, ib2) ->
+ tokenf en ib1 >>= (fun en ib1 ->
return (
(A.EnumName (en, namea)) +> A.rewrap ta,
(B.EnumName nameb, [ib1;ib2])
-> fail
-(* todo: iso on sign, if not mentioned then free. tochange?
+(* todo: iso on sign, if not mentioned then free. tochange?
* but that require to know if signed int because explicit
* signed int, or because implicit signed int.
*)
-and sign signa signb =
+and sign signa signb =
match signa, signb with
| None, None -> return (None, [])
- | Some signa, Some (signb, ib) ->
+ | Some signa, Some (signb, ib) ->
if equal_sign (term signa) signb
- then tokenf signa ib >>= (fun signa ib ->
+ then tokenf signa ib >>= (fun signa ib ->
return (Some signa, [ib])
)
else fail
| _, _ -> fail
-and minusize_list iixs =
- iixs +> List.fold_left (fun acc ii ->
- acc >>= (fun xs ys ->
- tokenf minusizer ii >>= (fun minus ii ->
+and minusize_list iixs =
+ iixs +> List.fold_left (fun acc ii ->
+ acc >>= (fun xs ys ->
+ tokenf minusizer ii >>= (fun minus ii ->
return (minus::xs, ii::ys)
))) (return ([],[]))
- >>= (fun _xsminys ys ->
+ >>= (fun _xsminys ys ->
return ((), List.rev ys)
)
-and storage_optional_allminus allminus stoa (stob, iistob) =
+and storage_optional_allminus allminus stoa (stob, iistob) =
(* "iso-by-absence" for storage, and return type. *)
- X.optional_storage_flag (fun optional_storage ->
+ X.optional_storage_flag (fun optional_storage ->
match stoa, stob with
- | None, (stobis, inline) ->
- let do_minus () =
- if allminus
- then
- minusize_list iistob >>= (fun () iistob ->
+ | None, (stobis, inline) ->
+ let do_minus () =
+ if allminus
+ then
+ minusize_list iistob >>= (fun () iistob ->
return (None, (stob, iistob))
)
else return (None, (stob, iistob))
| false, B.NoSto -> do_minus ()
| false, _ -> fail
| true, B.NoSto -> do_minus ()
- | true, _ ->
- if !Flag.show_misc
+ | true, _ ->
+ if !Flag.show_misc
then pr2_once "USING optional_storage builtin isomorphism";
do_minus()
)
- | Some x, ((stobis, inline)) ->
+ | Some x, ((stobis, inline)) ->
if equal_storage (term x) stobis
- then
- match iistob with
- | [i1] ->
- tokenf x i1 >>= (fun x i1 ->
- return (Some x, ((stobis, inline), [i1]))
- )
- (* or if have inline ? have to do a split_storage_inline a la
- * split_signb_baseb_ii *)
- | _ -> raise Impossible
+ then
+ let rec loop acc = function
+ [] -> fail
+ | i1::iistob ->
+ let try1 =
+ tokenf x i1 >>= (fun x i1 ->
+ let rebuilt = (List.rev acc) @ i1 :: iistob in
+ return (Some x, ((stobis, inline), rebuilt))) in
+ let try2 x = loop (i1::acc) iistob x in (* x for laziness *)
+ try1 >||> try2 in
+ loop [] iistob
else fail
)
-
-
-
-
-and fullType_optional_allminus allminus tya retb =
- match tya with
- | None ->
+and fullType_optional_allminus allminus tya retb =
+ match tya with
+ | None ->
if allminus
- then
- X.distrf_type minusizer retb >>= (fun _x retb ->
+ then
+ X.distrf_type minusizer retb >>= (fun _x retb ->
return (None, retb)
)
else return (None, retb)
- | Some tya ->
- fullType tya retb >>= (fun tya retb ->
+ | Some tya ->
+ fullType tya retb >>= (fun tya retb ->
return (Some tya, retb)
)
let ok = return ((),()) in
match a, b with
- | Type_cocci.VoidType, B.Void ->
+ | Type_cocci.VoidType, B.Void ->
assert (signa =*= None);
ok
- | Type_cocci.CharType, B.IntType B.CChar when signa =*= None ->
+ | Type_cocci.CharType, B.IntType B.CChar when signa =*= None ->
ok
- | Type_cocci.CharType, B.IntType (B.Si (signb, B.CChar2)) ->
- compatible_sign signa signb
- | Type_cocci.ShortType, B.IntType (B.Si (signb, B.CShort)) ->
+ | Type_cocci.CharType, B.IntType (B.Si (signb, B.CChar2)) ->
+ compatible_sign signa signb
+ | Type_cocci.ShortType, B.IntType (B.Si (signb, B.CShort)) ->
compatible_sign signa signb
- | Type_cocci.IntType, B.IntType (B.Si (signb, B.CInt)) ->
+ | Type_cocci.IntType, B.IntType (B.Si (signb, B.CInt)) ->
compatible_sign signa signb
- | Type_cocci.LongType, B.IntType (B.Si (signb, B.CLong)) ->
+ | Type_cocci.LongType, B.IntType (B.Si (signb, B.CLong)) ->
compatible_sign signa signb
- | _, B.IntType (B.Si (signb, B.CLongLong)) ->
+ | _, B.IntType (B.Si (signb, B.CLongLong)) ->
pr2_once "no longlong in cocci";
fail
| Type_cocci.FloatType, B.FloatType B.CFloat ->
- assert (signa =*= None);
+ assert (signa =*= None);
ok
| Type_cocci.DoubleType, B.FloatType B.CDouble ->
- assert (signa =*= None);
+ assert (signa =*= None);
ok
- | _, B.FloatType B.CLongDouble ->
+ | _, B.FloatType B.CLongDouble ->
pr2_once "no longdouble in cocci";
fail
| Type_cocci.BoolType, _ -> failwith "no booltype in C"
-
+
| _, (B.Void|B.FloatType _|B.IntType _) -> fail
and compatible_base_type_meta a signa qua b ii local =
match a, b with
| Type_cocci.MetaType(ida,keep,inherited),
- B.IntType (B.Si (signb, B.CChar2)) ->
+ B.IntType (B.Si (signb, B.CChar2)) ->
compatible_sign signa signb >>= fun _ _ ->
let newb = ((qua, (B.BaseType (B.IntType B.CChar),ii)),local) in
compatible_type a newb
- | Type_cocci.MetaType(ida,keep,inherited), B.IntType (B.Si (signb, ty)) ->
+ | Type_cocci.MetaType(ida,keep,inherited), B.IntType (B.Si (signb, ty)) ->
compatible_sign signa signb >>= fun _ _ ->
let newb =
((qua, (B.BaseType (B.IntType (B.Si (B.Signed, ty))),ii)),local) in
compatible_type a newb
- | _, B.FloatType B.CLongDouble ->
+ | _, B.FloatType B.CLongDouble ->
pr2_once "no longdouble in cocci";
fail
-
+
| _, (B.Void|B.FloatType _|B.IntType _) -> fail
-and compatible_type a (b,local) =
+and compatible_type a (b,local) =
let ok = return ((),()) in
let rec loop = function
- | Type_cocci.BaseType a, (qua, (B.BaseType b,ii)) ->
+ | Type_cocci.BaseType a, (qua, (B.BaseType b,ii)) ->
compatible_base_type a None b
- | Type_cocci.SignedT (signa,None), (qua, (B.BaseType b,ii)) ->
+ | Type_cocci.SignedT (signa,None), (qua, (B.BaseType b,ii)) ->
compatible_base_type Type_cocci.IntType (Some signa) b
- | Type_cocci.SignedT (signa,Some ty), (qua, (B.BaseType b,ii)) ->
+ | Type_cocci.SignedT (signa,Some ty), (qua, (B.BaseType b,ii)) ->
(match ty with
Type_cocci.BaseType ty ->
compatible_base_type ty (Some signa) b
compatible_base_type_meta ty (Some signa) qua b ii local
| _ -> failwith "not possible")
- | Type_cocci.Pointer a, (qub, (B.Pointer b, ii)) ->
+ | Type_cocci.Pointer a, (qub, (B.Pointer b, ii)) ->
loop (a,b)
| Type_cocci.FunctionPointer a, _ ->
failwith
(* no size info for cocci *)
loop (a,b)
| Type_cocci.StructUnionName (sua, _, sa),
- (qub, (B.StructUnionName (sub, sb),ii)) ->
+ (qub, (B.StructUnionName (sub, sb),ii)) ->
if equal_structUnion_type_cocci sua sub && sa =$= sb
then ok
else fail
| Type_cocci.EnumName (_, sa),
- (qub, (B.EnumName (sb),ii)) ->
+ (qub, (B.EnumName (sb),ii)) ->
if sa =$= sb
then ok
else fail
- | Type_cocci.TypeName sa, (qub, (B.TypeName (namesb, _typb),noii)) ->
+ | Type_cocci.TypeName sa, (qub, (B.TypeName (namesb, _typb),noii)) ->
let sb = Ast_c.str_of_name namesb in
- if sa =$= sb
+ if sa =$= sb
then ok
else fail
- | Type_cocci.ConstVol (qua, a), (qub, b) ->
- if (fst qub).B.const && (fst qub).B.volatile
+ | Type_cocci.ConstVol (qua, a), (qub, b) ->
+ if (fst qub).B.const && (fst qub).B.volatile
then
begin
pr2_once ("warning: the type is both const & volatile but cocci " ^
"does not handle that");
fail
end
- else
- if
- (match qua with
+ else
+ if
+ (match qua with
| Type_cocci.Const -> (fst qub).B.const
| Type_cocci.Volatile -> (fst qub).B.volatile
)
then loop (a,(Ast_c.nQ, b))
else fail
- | Type_cocci.MetaType (ida,keep,inherited), typb ->
+ | Type_cocci.MetaType (ida,keep,inherited), typb ->
let max_min _ =
Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_type typb) in
X.envf keep inherited (A.make_mcode ida, B.MetaTypeVal typb, max_min)
)
(* subtil: must be after the MetaType case *)
- | a, (qub, (B.TypeName (_namesb, Some b), noii)) ->
+ | a, (qub, (B.TypeName (_namesb, Some b), noii)) ->
(* kind of typedef iso *)
loop (a,b)
in
loop (a,b)
-and compatible_sign signa signb =
+and compatible_sign signa signb =
let ok = return ((),()) in
match signa, signb with
- | None, B.Signed
+ | None, B.Signed
| Some Type_cocci.Signed, B.Signed
| Some Type_cocci.Unsigned, B.UnSigned
-> ok
| _ -> fail
-and equal_structUnion_type_cocci a b =
+and equal_structUnion_type_cocci a b =
match a, b with
| Type_cocci.Struct, B.Struct -> true
| Type_cocci.Union, B.Union -> true
(*---------------------------------------------------------------------------*)
-and inc_file (a, before_after) (b, h_rel_pos) =
+and inc_file (a, before_after) (b, h_rel_pos) =
- let rec aux_inc (ass, bss) passed =
+ let rec aux_inc (ass, bss) passed =
match ass, bss with
| [], [] -> true
- | [A.IncDots], _ ->
+ | [A.IncDots], _ ->
let passed = List.rev passed in
(match before_after, !h_rel_pos with
| IncludeNothing, _ -> true
- | IncludeMcodeBefore, Some x ->
+ | IncludeMcodeBefore, Some x ->
List.mem passed (x.Ast_c.first_of)
- | IncludeMcodeAfter, Some x ->
+ | IncludeMcodeAfter, Some x ->
List.mem passed (x.Ast_c.last_of)
(* no info, maybe cos of a #include <xx.h> that was already in a .h *)
- | _, None -> false
+ | _, None -> false
)
| (A.IncPath x)::xs, y::ys -> x =$= y && aux_inc (xs, ys) (x::passed)
| _ -> failwith "IncDots not in last place or other pb"
-
+
in
match a, b with
- | A.Local ass, B.Local bss ->
+ | A.Local ass, B.Local bss ->
aux_inc (ass, bss) []
- | A.NonLocal ass, B.NonLocal bss ->
+ | A.NonLocal ass, B.NonLocal bss ->
aux_inc (ass, bss) []
| _ -> false
-
+
(*---------------------------------------------------------------------------*)
-and (define_params: sequence ->
- (A.define_param list, (string B.wrap) B.wrap2 list) matcher) =
- fun seqstyle eas ebs ->
+and (define_params: sequence ->
+ (A.define_param list, (string B.wrap) B.wrap2 list) matcher) =
+ fun seqstyle eas ebs ->
match seqstyle with
| Unordered -> failwith "not handling ooo"
- | Ordered ->
+ | Ordered ->
define_paramsbis eas (Ast_c.split_comma ebs) >>= (fun eas ebs_splitted ->
return (eas, (Ast_c.unsplit_comma ebs_splitted))
)
(* todo? facto code with argument and parameters ? *)
-and define_paramsbis = fun eas ebs ->
+and define_paramsbis = fun eas ebs ->
match eas, ebs with
| [], [] -> return ([], [])
| [], eb::ebs -> fail
- | ea::eas, ebs ->
+ | ea::eas, ebs ->
X.all_bound (A.get_inherited ea) >&&>
(match A.unwrap ea, ebs with
- | A.DPdots (mcode), ys ->
+ | A.DPdots (mcode), ys ->
(* '...' can take more or less the beginnings of the arguments *)
let startendxs = Common.zip (Common.inits ys) (Common.tails ys) in
- startendxs +> List.fold_left (fun acc (startxs, endxs) ->
+ startendxs +> List.fold_left (fun acc (startxs, endxs) ->
acc >||> (
(if null startxs
then
if mcode_contain_plus (mcodekind mcode)
- then fail
+ then fail
(* failwith "I have no token that I could accroche myself on" *)
else return (dots2metavar mcode, [])
- else
+ else
(match Common.last startxs with
| Right _ -> fail
- | Left _ ->
+ | Left _ ->
X.distrf_define_params (dots2metavar mcode) startxs
)
) >>= (fun mcode startxs ->
let mcode = metavar2dots mcode in
- define_paramsbis eas endxs >>= (fun eas endxs ->
+ define_paramsbis eas endxs >>= (fun eas endxs ->
return (
(A.DPdots (mcode) +> A.rewrap ea) ::eas,
startxs ++ endxs
)))
)
- ) fail
+ ) fail
- | A.DPComma ia1, Right ii::ebs ->
+ | A.DPComma ia1, Right ii::ebs ->
let ib1 = tuple_of_list1 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- define_paramsbis eas ebs >>= (fun eas ebs ->
+ tokenf ia1 ib1 >>= (fun ia1 ib1 ->
+ define_paramsbis eas ebs >>= (fun eas ebs ->
return (
(A.DPComma ia1 +> A.rewrap ea)::eas,
(Right [ib1])::ebs
)
))
- | A.DPComma ia1, ebs ->
+ | A.DPComma ia1, ebs ->
if mcode_contain_plus (mcodekind ia1)
then fail
- else
+ else
(define_paramsbis eas ebs) (* try optional comma trick *)
- | (A.OptDParam _ | A.UniqueDParam _), _ ->
+ | (A.OptDParam _ | A.UniqueDParam _), _ ->
failwith "handling Opt/Unique for define parameters"
| A.DPcircles (_), ys -> raise Impossible (* in Ordered mode *)
- | A.DParam ida, (Left (idb, ii))::ebs ->
+ | A.DParam ida, (Left (idb, ii))::ebs ->
let ib1 = tuple_of_list1 ii in
- ident DontKnow ida (idb, ib1) >>= (fun ida (idb, ib1) ->
- define_paramsbis eas ebs >>= (fun eas ebs ->
+ ident DontKnow ida (idb, ib1) >>= (fun ida (idb, ib1) ->
+ define_paramsbis eas ebs >>= (fun eas ebs ->
return (
(A.DParam ida)+> A.rewrap ea :: eas,
(Left (idb, [ib1]))::ebs
)))
-
+
| _unwrapx, (Right y)::ys -> raise Impossible
| _unwrapx, [] -> fail
)
-
+
(*****************************************************************************)
(* no global solution for positions here, because for a statement metavariable
we want a MetaStmtVal, and for the others, it's not clear what we want *)
-let rec (rule_elem_node: (A.rule_elem, Control_flow_c.node) matcher) =
- fun re node ->
- let rewrap x =
+let rec (rule_elem_node: (A.rule_elem, Control_flow_c.node) matcher) =
+ fun re node ->
+ let rewrap x =
x >>= (fun a b -> return (A.rewrap re a, F.rewrap node b))
in
X.all_bound (A.get_inherited re) >&&>
(* the metaRuleElem contains just '-' information. We dont need to add
* stuff in the environment. If we need stuff in environment, because
* there is a + S somewhere, then this will be done via MetaStmt, not
- * via MetaRuleElem.
+ * via MetaRuleElem.
* Can match TrueNode/FalseNode/... so must be placed before those cases.
*)
- | A.MetaRuleElem(mcode,keep,inherited), unwrap_node ->
+ | A.MetaRuleElem(mcode,keep,inherited), unwrap_node ->
let default = A.MetaRuleElem(mcode,keep,inherited), unwrap_node in
(match unwrap_node with
| F.CaseNode _
| F.TrueNode | F.FalseNode | F.AfterNode
- | F.LoopFallThroughNode | F.FallThroughNode
- | F.InLoopNode ->
- if X.mode =*= PatternMode
- then return default
+ | F.LoopFallThroughNode | F.FallThroughNode
+ | F.InLoopNode ->
+ if X.mode =*= PatternMode
+ then return default
else
if mcode_contain_plus (mcodekind mcode)
then failwith "try add stuff on fake node"
(* minusize or contextize a fake node is ok *)
else return default
- | F.EndStatement None ->
- if X.mode =*= PatternMode then return default
- else
+ | F.EndStatement None ->
+ if X.mode =*= PatternMode then return default
+ else
(* DEAD CODE NOW ? only useful in -no_cocci_vs_c_3 ?
if mcode_contain_plus (mcodekind mcode)
then
let fake_info = Ast_c.fakeInfo() in
- distrf distrf_node (mcodekind mcode)
- (F.EndStatement (Some fake_info))
+ distrf distrf_node (mcodekind mcode)
+ (F.EndStatement (Some fake_info))
else return unwrap_node
*)
raise Todo
-
- | F.EndStatement (Some i1) ->
- tokenf mcode i1 >>= (fun mcode i1 ->
+
+ | F.EndStatement (Some i1) ->
+ tokenf mcode i1 >>= (fun mcode i1 ->
return (
A.MetaRuleElem (mcode,keep, inherited),
F.EndStatement (Some i1)
))
- | F.FunHeader _ ->
+ | F.FunHeader _ ->
if X.mode =*= PatternMode then return default
else failwith "a MetaRuleElem can't transform a headfunc"
- | _n ->
- if X.mode =*= PatternMode then return default
- else
- X.distrf_node (generalize_mcode mcode) node >>= (fun mcode node ->
+ | _n ->
+ if X.mode =*= PatternMode then return default
+ else
+ X.distrf_node (generalize_mcode mcode) node >>= (fun mcode node ->
return (
A.MetaRuleElem(mcode,keep, inherited),
F.unwrap node
)
- (* rene cant have found that a state containing a fake/exit/... should be
- * transformed
+ (* rene cant have found that a state containing a fake/exit/... should be
+ * transformed
* TODO: and F.Fake ?
*)
| _, F.EndStatement _ | _, F.CaseNode _
(* cas general: a Meta can match everything. It matches only
* "header"-statement. We transform only MetaRuleElem, not MetaStmt.
- * So can't have been called in transform.
+ * So can't have been called in transform.
*)
| A.MetaStmt (ida,keep,metainfoMaybeTodo,inherited), F.Decl(_) -> fail
- | A.MetaStmt (ida,keep,metainfoMaybeTodo,inherited), unwrap_node ->
+ | A.MetaStmt (ida,keep,metainfoMaybeTodo,inherited), unwrap_node ->
(* todo: should not happen in transform mode *)
(match Control_flow_c.extract_fullstatement node with
- | Some stb ->
+ | Some stb ->
let max_min _ =
Lib_parsing_c.lin_col_by_pos (Lib_parsing_c.ii_of_stmt stb) in
X.envf keep inherited (ida, Ast_c.MetaStmtVal stb, max_min)
- (fun () ->
+ (fun () ->
(* no need tag ida, we can't be called in transform-mode *)
return (
A.MetaStmt (ida, keep, metainfoMaybeTodo, inherited),
)
(* not me?: *)
- | A.MetaStmtList _, _ ->
+ | A.MetaStmtList _, _ ->
failwith "not handling MetaStmtList"
| A.TopExp ea, F.DefineExpr eb ->
- expression ea eb >>= (fun ea eb ->
+ expression ea eb >>= (fun ea eb ->
return (
A.TopExp ea,
F.DefineExpr eb
))
-
+
| A.TopExp ea, F.DefineType eb ->
(match A.unwrap ea with
A.TypeExp(ft) ->
- fullType ft eb >>= (fun ft eb ->
+ fullType ft eb >>= (fun ft eb ->
return (
A.TopExp (A.rewrap ea (A.TypeExp(ft))),
F.DefineType eb
))
| _ -> fail)
-
+
(* It is important to put this case before the one that fails because
* that we still want and can transform.
*)
- | A.Exp exp, nodeb ->
+ | A.Exp exp, nodeb ->
(* kind of iso, initialisation vs affectation *)
- let node =
+ let node =
match A.unwrap exp, nodeb with
- | A.Assignment (ea, op, eb, true), F.Decl decl ->
+ | A.Assignment (ea, op, eb, true), F.Decl decl ->
initialisation_to_affectation decl +> F.rewrap node
| _ -> node
in
- (* Now keep fullstatement inside the control flow node,
+ (* Now keep fullstatement inside the control flow node,
* so that can then get in a MetaStmtVar the fullstatement to later
- * pp back when the S is in a +. But that means that
+ * pp back when the S is in a +. But that means that
* Exp will match an Ifnode even if there is no such exp
* inside the condition of the Ifnode (because the exp may
* be deeper, in the then branch). So have to not visit
* all inside a node anymore.
- *
+ *
* update: j'ai choisi d'accrocher au noeud du CFG à la
- * fois le fullstatement et le partialstatement et appeler le
+ * fois le fullstatement et le partialstatement et appeler le
* visiteur que sur le partialstatement.
*)
- let expfn =
+ let expfn =
match Ast_cocci.get_pos re with
| None -> expression
- | Some pos ->
- (fun ea eb ->
- let (max,min) =
+ | Some pos ->
+ (fun ea eb ->
+ let (max,min) =
Lib_parsing_c.max_min_by_pos (Lib_parsing_c.ii_of_expr eb) in
let keep = Type_cocci.Unitary in
let inherited = false in
let max_min _ = failwith "no pos" in
X.envf keep inherited (pos, B.MetaPosVal (min,max), max_min)
- (fun () ->
+ (fun () ->
expression ea eb
)
)
in
- X.cocciExp expfn exp node >>= (fun exp node ->
+ X.cocciExp expfn exp node >>= (fun exp node ->
return (
A.Exp exp,
F.unwrap node
)
)
- | A.Ty ty, nodeb ->
- X.cocciTy fullType ty node >>= (fun ty node ->
+ | A.Ty ty, nodeb ->
+ X.cocciTy fullType ty node >>= (fun ty node ->
return (
A.Ty ty,
F.unwrap node
)
)
- | A.TopInit init, nodeb ->
- X.cocciInit initialiser init node >>= (fun init node ->
+ | A.TopInit init, nodeb ->
+ X.cocciInit initialiser init node >>= (fun init node ->
return (
A.TopInit init,
F.unwrap node
f_attr = attrs;
f_body = body;
f_old_c_style = oldstyle;
- }, ii) ->
+ }, ii) ->
assert (null body);
if oldstyle <> None
match
List.filter (function A.FStorage(s) -> true | _ -> false) fninfoa
with [A.FStorage(s)] -> Some s | _ -> None in
- let tya =
+ let tya =
match List.filter (function A.FType(s) -> true | _ -> false) fninfoa
with [A.FType(t)] -> Some t | _ -> None in
with [A.FAttr(a)] -> failwith "not checking attributes" | _ -> ());
(match ii with
- | ioparenb::icparenb::iifakestart::iistob ->
+ | ioparenb::icparenb::iifakestart::iistob ->
(* maybe important to put ident as the first tokens to transform.
* It's related to transform_proto. So don't change order
* between the >>=.
*)
- ident_cpp LocalFunction ida nameidb >>= (fun ida nameidb ->
- X.tokenf_mck mckstart iifakestart >>= (fun mckstart iifakestart ->
+ ident_cpp LocalFunction ida nameidb >>= (fun ida nameidb ->
+ X.tokenf_mck mckstart iifakestart >>= (fun mckstart iifakestart ->
tokenf oparen ioparenb >>= (fun oparen ioparenb ->
tokenf cparen icparenb >>= (fun cparen icparenb ->
- parameters (seqstyle paramsa)
+ parameters (seqstyle paramsa)
(A.undots paramsa) paramsb >>=
- (fun paramsaundots paramsb ->
+ (fun paramsaundots paramsb ->
let paramsa = redots paramsa paramsaundots in
- storage_optional_allminus allminus
- stoa (stob, iistob) >>= (fun stoa (stob, iistob) ->
+ storage_optional_allminus allminus
+ stoa (stob, iistob) >>= (fun stoa (stob, iistob) ->
(
- if isvaargs
- then
+ if isvaargs
+ then
pr2_once
("Not handling well variable length arguments func. "^
"You have been warned");
if allminus
then minusize_list iidotsb
else return ((),iidotsb)
- ) >>= (fun () iidotsb ->
-
- fullType_optional_allminus allminus tya retb >>= (fun tya retb ->
+ ) >>= (fun () iidotsb ->
+
+ fullType_optional_allminus allminus tya retb >>= (fun tya retb ->
- let fninfoa =
+ let fninfoa =
(match stoa with Some st -> [A.FStorage st] | None -> []) ++
(match tya with Some t -> [A.FType t] | None -> [])
- | A.Decl (mckstart,allminus,decla), F.Decl declb ->
- declaration (mckstart,allminus,decla) declb >>=
- (fun (mckstart,allminus,decla) declb ->
+ | A.Decl (mckstart,allminus,decla), F.Decl declb ->
+ declaration (mckstart,allminus,decla) declb >>=
+ (fun (mckstart,allminus,decla) declb ->
return (
A.Decl (mckstart,allminus,decla),
F.Decl declb
))
- | A.SeqStart mcode, F.SeqStart (st, level, i1) ->
- tokenf mcode i1 >>= (fun mcode i1 ->
+ | A.SeqStart mcode, F.SeqStart (st, level, i1) ->
+ tokenf mcode i1 >>= (fun mcode i1 ->
return (
- A.SeqStart mcode,
+ A.SeqStart mcode,
F.SeqStart (st, level, i1)
))
- | A.SeqEnd mcode, F.SeqEnd (level, i1) ->
- tokenf mcode i1 >>= (fun mcode i1 ->
+ | A.SeqEnd mcode, F.SeqEnd (level, i1) ->
+ tokenf mcode i1 >>= (fun mcode i1 ->
return (
A.SeqEnd mcode,
F.SeqEnd (level, i1)
))
- | A.ExprStatement (ea, ia1), F.ExprStatement (st, (Some eb, ii)) ->
- let ib1 = tuple_of_list1 ii in
- expression ea eb >>= (fun ea eb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
+ | A.ExprStatement (ea, ia1), F.ExprStatement (st, (Some eb, ii)) ->
+ let ib1 = tuple_of_list1 ii in
+ expression ea eb >>= (fun ea eb ->
+ tokenf ia1 ib1 >>= (fun ia1 ib1 ->
return (
A.ExprStatement (ea, ia1),
F.ExprStatement (st, (Some eb, [ib1]))
))
- | A.IfHeader (ia1,ia2, ea, ia3), F.IfHeader (st, (eb,ii)) ->
+ | A.IfHeader (ia1,ia2, ea, ia3), F.IfHeader (st, (eb,ii)) ->
let (ib1, ib2, ib3) = tuple_of_list3 ii in
- expression ea eb >>= (fun ea eb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
+ expression ea eb >>= (fun ea eb ->
+ tokenf ia1 ib1 >>= (fun ia1 ib1 ->
+ tokenf ia2 ib2 >>= (fun ia2 ib2 ->
+ tokenf ia3 ib3 >>= (fun ia3 ib3 ->
return (
A.IfHeader (ia1, ia2, ea, ia3),
F.IfHeader (st, (eb,[ib1;ib2;ib3]))
)))))
- | A.Else ia, F.Else ib ->
- tokenf ia ib >>= (fun ia ib ->
+ | A.Else ia, F.Else ib ->
+ tokenf ia ib >>= (fun ia ib ->
return (A.Else ia, F.Else ib)
)
- | A.WhileHeader (ia1, ia2, ea, ia3), F.WhileHeader (st, (eb, ii)) ->
+ | A.WhileHeader (ia1, ia2, ea, ia3), F.WhileHeader (st, (eb, ii)) ->
let (ib1, ib2, ib3) = tuple_of_list3 ii in
- expression ea eb >>= (fun ea eb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
+ expression ea eb >>= (fun ea eb ->
+ tokenf ia1 ib1 >>= (fun ia1 ib1 ->
+ tokenf ia2 ib2 >>= (fun ia2 ib2 ->
+ tokenf ia3 ib3 >>= (fun ia3 ib3 ->
return (
- A.WhileHeader (ia1, ia2, ea, ia3),
+ A.WhileHeader (ia1, ia2, ea, ia3),
F.WhileHeader (st, (eb, [ib1;ib2;ib3]))
)))))
- | A.DoHeader ia, F.DoHeader (st, ib) ->
- tokenf ia ib >>= (fun ia ib ->
+ | A.DoHeader ia, F.DoHeader (st, ib) ->
+ tokenf ia ib >>= (fun ia ib ->
return (
- A.DoHeader ia,
+ A.DoHeader ia,
F.DoHeader (st, ib)
))
- | A.WhileTail (ia1,ia2,ea,ia3,ia4), F.DoWhileTail (eb, ii) ->
+ | A.WhileTail (ia1,ia2,ea,ia3,ia4), F.DoWhileTail (eb, ii) ->
let (ib1, ib2, ib3, ib4) = tuple_of_list4 ii in
- expression ea eb >>= (fun ea eb ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
- tokenf ia4 ib4 >>= (fun ia4 ib4 ->
+ expression ea eb >>= (fun ea eb ->
+ tokenf ia1 ib1 >>= (fun ia1 ib1 ->
+ tokenf ia2 ib2 >>= (fun ia2 ib2 ->
+ tokenf ia3 ib3 >>= (fun ia3 ib3 ->
+ tokenf ia4 ib4 >>= (fun ia4 ib4 ->
return (
- A.WhileTail (ia1,ia2,ea,ia3,ia4),
+ A.WhileTail (ia1,ia2,ea,ia3,ia4),
F.DoWhileTail (eb, [ib1;ib2;ib3;ib4])
))))))
| A.IteratorHeader (ia1, ia2, eas, ia3), F.MacroIterHeader (st, ((s,ebs),ii))
- ->
+ ->
let (ib1, ib2, ib3) = tuple_of_list3 ii in
- ident DontKnow ia1 (s, ib1) >>= (fun ia1 (s, ib1) ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
- arguments (seqstyle eas) (A.undots eas) ebs >>= (fun easundots ebs ->
+ ident DontKnow ia1 (s, ib1) >>= (fun ia1 (s, ib1) ->
+ tokenf ia2 ib2 >>= (fun ia2 ib2 ->
+ tokenf ia3 ib3 >>= (fun ia3 ib3 ->
+ arguments (seqstyle eas) (A.undots eas) ebs >>= (fun easundots ebs ->
let eas = redots eas easundots in
return (
- A.IteratorHeader (ia1, ia2, eas, ia3),
+ A.IteratorHeader (ia1, ia2, eas, ia3),
F.MacroIterHeader (st, ((s,ebs), [ib1;ib2;ib3]))
)))))
-
- | A.ForHeader (ia1, ia2, ea1opt, ia3, ea2opt, ia4, ea3opt, ia5),
+
+ | A.ForHeader (ia1, ia2, ea1opt, ia3, ea2opt, ia4, ea3opt, ia5),
F.ForHeader (st, (((eb1opt,ib3s), (eb2opt,ib4s), (eb3opt,ib4vide)), ii))
- ->
+ ->
assert (null ib4vide);
let (ib1, ib2, ib5) = tuple_of_list3 ii in
let ib3 = tuple_of_list1 ib3s in
let ib4 = tuple_of_list1 ib4s in
-
+
tokenf ia1 ib1 >>= (fun ia1 ib1 ->
tokenf ia2 ib2 >>= (fun ia2 ib2 ->
tokenf ia3 ib3 >>= (fun ia3 ib3 ->
| A.SwitchHeader(ia1,ia2,ea,ia3), F.SwitchHeader (st, (eb,ii)) ->
let (ib1, ib2, ib3) = tuple_of_list3 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- tokenf ia3 ib3 >>= (fun ia3 ib3 ->
- expression ea eb >>= (fun ea eb ->
+ tokenf ia1 ib1 >>= (fun ia1 ib1 ->
+ tokenf ia2 ib2 >>= (fun ia2 ib2 ->
+ tokenf ia3 ib3 >>= (fun ia3 ib3 ->
+ expression ea eb >>= (fun ea eb ->
return (
- A.SwitchHeader(ia1,ia2,ea,ia3),
+ A.SwitchHeader(ia1,ia2,ea,ia3),
F.SwitchHeader (st, (eb,[ib1;ib2;ib3]))
)))))
-
- | A.Break (ia1, ia2), F.Break (st, ((),ii)) ->
+
+ | A.Break (ia1, ia2), F.Break (st, ((),ii)) ->
let (ib1, ib2) = tuple_of_list2 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
+ tokenf ia1 ib1 >>= (fun ia1 ib1 ->
+ tokenf ia2 ib2 >>= (fun ia2 ib2 ->
return (
- A.Break (ia1, ia2),
+ A.Break (ia1, ia2),
F.Break (st, ((),[ib1;ib2]))
)))
- | A.Continue (ia1, ia2), F.Continue (st, ((),ii)) ->
+ | A.Continue (ia1, ia2), F.Continue (st, ((),ii)) ->
let (ib1, ib2) = tuple_of_list2 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
+ tokenf ia1 ib1 >>= (fun ia1 ib1 ->
+ tokenf ia2 ib2 >>= (fun ia2 ib2 ->
return (
- A.Continue (ia1, ia2),
+ A.Continue (ia1, ia2),
F.Continue (st, ((),[ib1;ib2]))
)))
- | A.Return (ia1, ia2), F.Return (st, ((),ii)) ->
+ | A.Return (ia1, ia2), F.Return (st, ((),ii)) ->
let (ib1, ib2) = tuple_of_list2 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
+ tokenf ia1 ib1 >>= (fun ia1 ib1 ->
+ tokenf ia2 ib2 >>= (fun ia2 ib2 ->
return (
- A.Return (ia1, ia2),
+ A.Return (ia1, ia2),
F.Return (st, ((),[ib1;ib2]))
)))
- | A.ReturnExpr (ia1, ea, ia2), F.ReturnExpr (st, (eb, ii)) ->
+ | A.ReturnExpr (ia1, ea, ia2), F.ReturnExpr (st, (eb, ii)) ->
let (ib1, ib2) = tuple_of_list2 ii in
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- expression ea eb >>= (fun ea eb ->
+ tokenf ia1 ib1 >>= (fun ia1 ib1 ->
+ tokenf ia2 ib2 >>= (fun ia2 ib2 ->
+ expression ea eb >>= (fun ea eb ->
return (
- A.ReturnExpr (ia1, ea, ia2),
+ A.ReturnExpr (ia1, ea, ia2),
F.ReturnExpr (st, (eb, [ib1;ib2]))
))))
- | A.Include(incla,filea),
+ | A.Include(incla,filea),
F.Include {B.i_include = (fileb, ii);
B.i_rel_pos = h_rel_pos;
B.i_is_in_ifdef = inifdef;
B.i_content = copt;
} ->
assert (copt =*= None);
-
- let include_requirment =
+
+ let include_requirment =
match mcodekind incla, mcodekind filea with
- | A.CONTEXT (_, A.BEFORE _), _ ->
+ | A.CONTEXT (_, A.BEFORE _), _ ->
IncludeMcodeBefore
- | _, A.CONTEXT (_, A.AFTER _) ->
+ | _, A.CONTEXT (_, A.AFTER _) ->
IncludeMcodeAfter
- | _ ->
+ | _ ->
IncludeNothing
in
- let (inclb, iifileb) = tuple_of_list2 ii in
+ let (inclb, iifileb) = tuple_of_list2 ii in
if inc_file (term filea, include_requirment) (fileb, h_rel_pos)
- then
- tokenf incla inclb >>= (fun incla inclb ->
- tokenf filea iifileb >>= (fun filea iifileb ->
+ then
+ tokenf incla inclb >>= (fun incla inclb ->
+ tokenf filea iifileb >>= (fun filea iifileb ->
return (
A.Include(incla, filea),
F.Include {B.i_include = (fileb, [inclb;iifileb]);
| A.DefineHeader(definea,ida,params), F.DefineHeader ((idb, ii), defkind) ->
let (defineb, iidb, ieol) = tuple_of_list3 ii in
- ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
- tokenf definea defineb >>= (fun definea defineb ->
+ ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
+ tokenf definea defineb >>= (fun definea defineb ->
(match A.unwrap params, defkind with
- | A.NoParams, B.DefineVar ->
+ | A.NoParams, B.DefineVar ->
return (
- A.NoParams +> A.rewrap params,
+ A.NoParams +> A.rewrap params,
B.DefineVar
)
- | A.DParams(lpa,eas,rpa), (B.DefineFunc (ebs, ii)) ->
+ | A.DParams(lpa,eas,rpa), (B.DefineFunc (ebs, ii)) ->
let (lpb, rpb) = tuple_of_list2 ii in
- tokenf lpa lpb >>= (fun lpa lpb ->
- tokenf rpa rpb >>= (fun rpa rpb ->
+ tokenf lpa lpb >>= (fun lpa lpb ->
+ tokenf rpa rpb >>= (fun rpa rpb ->
- define_params (seqstyle eas) (A.undots eas) ebs >>=
- (fun easundots ebs ->
+ define_params (seqstyle eas) (A.undots eas) ebs >>=
+ (fun easundots ebs ->
let eas = redots eas easundots in
return (
A.DParams (lpa,eas,rpa) +> A.rewrap params,
)
)))
| _ -> fail
- ) >>= (fun params defkind ->
+ ) >>= (fun params defkind ->
return (
A.DefineHeader (definea, ida, params),
F.DefineHeader ((idb,[defineb;iidb;ieol]),defkind)
))
- | A.Default(def,colon), F.Default (st, ((),ii)) ->
+ | A.Default(def,colon), F.Default (st, ((),ii)) ->
let (ib1, ib2) = tuple_of_list2 ii in
- tokenf def ib1 >>= (fun def ib1 ->
- tokenf colon ib2 >>= (fun colon ib2 ->
+ tokenf def ib1 >>= (fun def ib1 ->
+ tokenf colon ib2 >>= (fun colon ib2 ->
return (
- A.Default(def,colon),
+ A.Default(def,colon),
F.Default (st, ((),[ib1;ib2]))
)))
-
-
- | A.Case(case,ea,colon), F.Case (st, (eb,ii)) ->
+
+
+ | A.Case(case,ea,colon), F.Case (st, (eb,ii)) ->
let (ib1, ib2) = tuple_of_list2 ii in
- tokenf case ib1 >>= (fun case ib1 ->
- expression ea eb >>= (fun ea eb ->
- tokenf colon ib2 >>= (fun colon ib2 ->
+ tokenf case ib1 >>= (fun case ib1 ->
+ expression ea eb >>= (fun ea eb ->
+ tokenf colon ib2 >>= (fun colon ib2 ->
return (
- A.Case(case,ea,colon),
+ A.Case(case,ea,colon),
F.Case (st, (eb,[ib1;ib2]))
))))
(* only occurs in the predicates generated by asttomember *)
- | A.DisjRuleElem eas, _ ->
+ | A.DisjRuleElem eas, _ ->
(eas +>
List.fold_left (fun acc ea -> acc >|+|> (rule_elem_node ea node)) fail)
>>= (fun ea eb -> return (A.unwrap ea,F.unwrap eb))
(* have not a counter part in coccinelle, for the moment *)
(* todo?: print a warning at least ? *)
- | _, F.CaseRange _
+ | _, F.CaseRange _
| _, F.Asm _
| _, F.MacroTop _
-> fail2()
| _, (F.IfdefEndif _|F.IfdefElse _|F.IfdefHeader _)
-> fail2 ()
- | _,
+ | _,
(F.MacroStmt (_, _)| F.DefineDoWhileZeroHeader _| F.EndNode|F.TopNode)
-> fail
- | _,
+ | _,
(F.Label (_, _, _)|F.Break (_, _)|F.Continue (_, _)|F.Default (_, _)|
F.Case (_, _)|F.Include _|F.Goto _|F.ExprStatement _|
F.DefineType _|F.DefineExpr _|F.DefineTodo|
HCoop / bpt / coccinelle.git / blobdiff