-(*
-* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
-* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
-* 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.
-*)
-
+(* Yoann Padioleau, Julia Lawall
+ *
+ * Copyright (C) 2006, 2007, 2008 Ecole des Mines de Nantes
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License (GPL)
+ * version 2 as published by the Free Software Foundation.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * file license.txt for more details.
+ *
+ * This file was part of Coccinelle.
+ *)
open Common
(*****************************************************************************)
(* Wrappers *)
(*****************************************************************************)
+let pr2, pr2_once = Common.mk_pr2_wrappers Flag_matcher.verbose_matcher
(*****************************************************************************)
(* Helpers *)
type sequence = Ordered | Unordered
-let seqstyle eas =
- match A.unwrap eas with
- | A.DOTS _ -> Ordered
- | A.CIRCLES _ -> Unordered
+let seqstyle eas =
+ match A.unwrap eas with
+ | A.DOTS _ -> Ordered
+ | A.CIRCLES _ -> Unordered
| A.STARS _ -> failwith "not handling stars"
let (redots : 'a A.dots -> 'a list -> 'a A.dots)=fun eas easundots ->
let mcode_contain_plus = function
| A.CONTEXT (_,A.NOTHING) -> false
| A.CONTEXT _ -> true
- | A.MINUS (_,[]) -> false
- | A.MINUS (_,x::xs) -> true
- | A.PLUS -> raise Impossible
+ | A.MINUS (_,_,_,[]) -> false
+ | A.MINUS (_,_,_,x::xs) -> true
+ | A.PLUS _ -> raise Impossible
let mcode_simple_minus = function
- | A.MINUS (_,[]) -> true
+ | A.MINUS (_,_,_,[]) -> true
| _ -> false
let minusizer =
("fake","fake"),
- {A.line = 0; column =0; A.strbef=[]; A.straft=[];},
- (A.MINUS(A.DontCarePos, [])),
+ {A.line = 0; A.column =0; A.strbef=[]; A.straft=[];},
+ (A.MINUS(A.DontCarePos,[],-1,[])),
A.NoMetaPos
let generalize_mcode ia =
let (s1, i, mck, pos) = ia in
let new_mck =
match mck with
- | A.PLUS -> raise Impossible
+ | A.PLUS _ -> raise Impossible
| A.CONTEXT (A.NoPos,x) ->
A.CONTEXT (A.DontCarePos,x)
- | A.MINUS (A.NoPos,x) ->
- A.MINUS (A.DontCarePos,x)
+ | A.MINUS (A.NoPos,inst,adj,x) ->
+ A.MINUS (A.DontCarePos,inst,adj,x)
| A.CONTEXT ((A.FixPos _|A.DontCarePos), _)
- | A.MINUS ((A.FixPos _|A.DontCarePos), _)
+ | A.MINUS ((A.FixPos _|A.DontCarePos), _, _, _)
->
raise Impossible
in
(* 0x0 is equivalent to 0, value format isomorphism *)
let equal_c_int s1 s2 =
try
- int_of_string s1 = int_of_string s2
+ int_of_string s1 =|= int_of_string s2
with Failure("int_of_string") ->
s1 =$= s2
| Ast_c.MetaListlenVal a, Ast_c.MetaListlenVal b -> a =|= 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 ->
+ Lib_parsing_c.al_params a =*= Lib_parsing_c.al_params b
+
+ | 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) ->
+ List.exists
+ (function (flb,ceb,posb1,posb2) ->
+ fla =$= flb && cea =$= ceb &&
+ Ast_c.equal_posl posa1 posb1 && Ast_c.equal_posl posa2 posb2)
+ l2)
+ l1
+
+ | (B.MetaPosValList _|B.MetaListlenVal _|B.MetaPosVal _|B.MetaStmtVal _
+ |B.MetaTypeVal _ |B.MetaInitVal _
+ |B.MetaParamListVal _|B.MetaParamVal _|B.MetaExprListVal _
+ |B.MetaExprVal _|B.MetaLocalFuncVal _|B.MetaFuncVal _|B.MetaIdVal _
+ ), _
+ -> raise Impossible
+
+(* probably only one argument needs to be stripped, because inherited
+metavariables containing expressions are stripped in advance. But don't
+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.MetaFuncVal a, Ast_c.MetaFuncVal b -> a =$= b
+ | Ast_c.MetaLocalFuncVal a, Ast_c.MetaLocalFuncVal b ->
+ (* do something more ? *)
+ a =$= b
+
+ (* al_expr before comparing !!! and accept when they match.
+ * Note that here we have Astc._expression, so it is a match
+ * modulo isomorphism (there is no metavariable involved here,
+ * 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 ->
+ Lib_parsing_c.al_inh_expr a =*= Lib_parsing_c.al_inh_expr 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 ->
+ Lib_parsing_c.al_inh_statement a =*= Lib_parsing_c.al_inh_statement 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 ->
+ (* 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 ->
Lib_parsing_c.al_param a =*= Lib_parsing_c.al_param b
| Ast_c.MetaParamListVal a, Ast_c.MetaParamListVal b ->
(function (fla,cea,posa1,posa2) ->
List.exists
(function (flb,ceb,posb1,posb2) ->
- fla = flb && cea = ceb &&
+ fla =$= flb && cea =$= ceb &&
Ast_c.equal_posl posa1 posb1 && Ast_c.equal_posl posa2 posb2)
l2)
l1
| B.IntType (B.CChar), ["char",i1] -> None, [i1]
- | B.IntType (B.Si (sign, base)), xs ->
- (match sign, base, xs with
- | B.Signed, B.CChar2, ["signed",i1;"char",i2] ->
- Some (B.Signed, i1), [i2]
- | B.UnSigned, B.CChar2, ["unsigned",i1;"char",i2] ->
- Some (B.UnSigned, i1), [i2]
-
- | B.Signed, B.CShort, ["short",i1] ->
- None, [i1]
- | B.Signed, B.CShort, ["signed",i1;"short",i2] ->
- Some (B.Signed, i1), [i2]
- | B.UnSigned, B.CShort, ["unsigned",i1;"short",i2] ->
- Some (B.UnSigned, i1), [i2]
- | B.Signed, B.CShort, ["short",i1;"int",i2] ->
- None, [i1;i2]
-
- | B.Signed, B.CInt, ["int",i1] ->
- None, [i1]
- | B.Signed, B.CInt, ["signed",i1;"int",i2] ->
- Some (B.Signed, i1), [i2]
- | B.UnSigned, B.CInt, ["unsigned",i1;"int",i2] ->
- Some (B.UnSigned, i1), [i2]
-
- | B.Signed, B.CInt, ["signed",i1;] ->
- Some (B.Signed, i1), []
- | B.UnSigned, B.CInt, ["unsigned",i1;] ->
- Some (B.UnSigned, i1), []
-
- | B.Signed, B.CLong, ["long",i1] ->
- None, [i1]
- | B.Signed, B.CLong, ["long",i1;"int",i2] ->
- None, [i1;i2]
- | B.Signed, B.CLong, ["signed",i1;"long",i2] ->
- Some (B.Signed, i1), [i2]
- | B.UnSigned, B.CLong, ["unsigned",i1;"long",i2] ->
- Some (B.UnSigned, i1), [i2]
-
- | B.Signed, B.CLongLong, ["long",i1;"long",i2] -> None, [i1;i2]
- | B.Signed, B.CLongLong, ["signed",i1;"long",i2;"long",i3] ->
- Some (B.Signed, i1), [i2;i3]
- | B.UnSigned, B.CLongLong, ["unsigned",i1;"long",i2;"long",i3] ->
- Some (B.UnSigned, i1), [i2;i3]
-
-
- | B.UnSigned, B.CShort, ["unsigned",i1;"short",i2; "int", i3] ->
- Some (B.UnSigned, i1), [i2;i3]
-
-
-
- | _ -> failwith "strange type1, maybe because of weird order"
- )
- | _ -> failwith "strange type2, maybe because of weird order"
+ | B.IntType (B.Si (sign, base)), xs ->
+ let (signed,rest) =
+ match (sign,xs) with
+ (_,[]) -> None,[]
+ | (B.Signed,(("signed",i1)::rest)) -> (Some (B.Signed,i1),rest)
+ | (B.Signed,rest) -> (None,rest)
+ | (B.UnSigned,(("unsigned",i1)::rest)) -> (Some (B.UnSigned,i1),rest)
+ | (B.UnSigned,rest) -> (* is this case possible? *) (None,rest) in
+ (* The original code only allowed explicit signed and unsigned for char,
+ while this code allows char by itself. Not sure that needs to be
+ checked for here. If it does, then add a special case. *)
+ let base_res =
+ match (base,rest) with
+ B.CInt, ["int",i1] -> [i1]
+ | B.CInt, [] -> []
+
+ | B.CInt, ["",i1] -> (* no type is specified at all *)
+ (match i1.B.pinfo with
+ B.FakeTok(_,_) -> []
+ | _ -> failwith ("unrecognized signed int: "^
+ (String.concat " "(List.map fst iis))))
+
+ | B.CChar2, ["char",i2] -> [i2]
+
+ | B.CShort, ["short",i1] -> [i1]
+ | B.CShort, ["short",i1;"int",i2] -> [i1;i2]
+
+ | B.CLong, ["long",i1] -> [i1]
+ | B.CLong, ["long",i1;"int",i2] -> [i1;i2]
+
+ | B.CLongLong, ["long",i1;"long",i2] -> [i1;i2]
+ | B.CLongLong, ["long",i1;"long",i2;"int",i3] -> [i1;i2;i3]
+
+ | _ ->
+ failwith ("strange type1, maybe because of weird order: "^
+ (String.concat " " (List.map fst iis))) in
+ (signed,base_res)
+ | _ -> failwith ("strange type2, maybe because of weird order: "^
+ (String.concat " " (List.map fst iis)))
(*---------------------------------------------------------------------------*)
| [x] ->
let ({B.v_namei = var;
B.v_type = returnType;
+ B.v_type_bis = tybis;
B.v_storage = storage;
B.v_local = local},
iisep) = x in
+
+
(match var with
- | Some ((s, ini), iis::iini) ->
- (match ini with
- | Some (B.InitExpr e, ii_empty2) ->
+ | Some (name, iniopt) ->
+ (match iniopt with
+ | Some (iini, (B.InitExpr e, ii_empty2)) ->
+
let local =
match local with
Ast_c.NotLocalDecl -> Ast_c.NotLocalVar
- | Ast_c.LocalDecl -> Ast_c.LocalVar (iis.Ast_c.pinfo) in
-
+ | Ast_c.LocalDecl ->
+ Ast_c.LocalVar (Ast_c.info_of_type returnType) in
+
+ 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 ->
+ ty_with_typename_completed
+ | None -> raise Impossible
+ in
+
let typ =
- ref (Some ((Lib_parsing_c.al_type returnType),local),
+ ref (Some (typexp,local),
Ast_c.NotTest) in
- let id = (B.Ident s, typ),[iis] in
- F.DefineExpr
- ((B.Assignment (id, B.SimpleAssign, e),
- Ast_c.noType()), iini)
+ let ident = name in
+ let idexpr =
+ Ast_c.mk_e_bis (B.Ident (ident)) typ Ast_c.noii
+ in
+ let assign =
+ Ast_c.mk_e
+ (B.Assignment (idexpr,B.SimpleAssign, e)) [iini] in
+ F.DefineExpr assign
+
| _ -> F.Decl decl
)
| _ -> F.Decl decl
(unit -> Common.filename * string * Ast_c.posl * Ast_c.posl) ->
(unit -> tin -> 'x tout) -> (tin -> 'x tout)
- val check_constraints :
+ val check_idconstraint :
+ ('a -> 'b -> bool) -> 'a -> 'b ->
+ (unit -> tin -> 'x tout) -> (tin -> 'x tout)
+
+ val check_constraints_ne :
('a, 'b) matcher -> 'a list -> 'b ->
(unit -> tin -> 'x tout) -> (tin -> 'x tout)
(*****************************************************************************)
module COCCI_VS_C =
- functor (X : PARAM) ->
+ functor (X : PARAM) ->
struct
type ('a, 'b) matcher = 'a -> 'b -> X.tin -> ('a * 'b) X.tout
let dots2metavar (_,info,mcodekind,pos) = (("","..."),info,mcodekind,pos)
let metavar2dots (_,info,mcodekind,pos) = ("...",info,mcodekind,pos)
+let satisfies_iconstraint 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
+
+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
+
(*---------------------------------------------------------------------------*)
(* toc:
* - expression
(* old: before have a MetaConst. Now we factorize and use 'form' to
* differentiate between different cases *)
let rec matches_id = function
- B.Ident(c) -> true
+ B.Ident(name) -> true
| B.Cast(ty,e) -> matches_id (B.unwrap_expr e)
| _ -> false in
let form_ok =
| (A.CONST,e) ->
let rec matches = function
B.Constant(c) -> true
- | B.Ident idb when idb =~ "^[A-Z_][A-Z_0-9]*$" ->
- pr2_once ("warning: I consider " ^ idb ^ " as a constant");
- true
+ | 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
+ end
+ else false
| B.Cast(ty,e) -> matches (B.unwrap_expr e)
| B.Unary(e,B.UnMinus) -> matches (B.unwrap_expr e)
| B.SizeOfExpr(exp) -> true
pr2_once ("Missing type information. Certainly a pb in " ^
"annotate_typer.ml");
fail
-
- | Some tas, Some tb ->
- tas +> List.fold_left (fun acc ta ->
+
+ | Some tas, Some tb ->
+ tas +> List.fold_left (fun acc ta ->
acc >|+|> compatible_type ta tb) fail
) >>=
(fun () () ->
- X.check_constraints expression constraints 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
- ))
- )))
+ 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
+ ))
+ )))
else fail
-
+
(* old:
* | A.MetaExpr(ida,false,opttypa,_inherited), expb ->
* D.distribute_mck (mcodekind ida) D.distribute_mck_e expb binding
| A.Edots (_, Some expr), _ -> failwith "not handling when on Edots"
- | A.Ident ida, ((B.Ident idb, typ),ii) ->
- let ib1 = tuple_of_list1 ii in
- ident DontKnow ida (idb, ib1) >>= (fun ida (idb, ib1) ->
+ | A.Ident ida, ((B.Ident (nameidb), typ),noii) ->
+ assert (null noii);
+ ident_cpp DontKnow ida nameidb >>= (fun ida nameidb ->
return (
((A.Ident ida)) +> wa,
- ((B.Ident idb, typ),[ib1])
+ ((B.Ident (nameidb), typ),Ast_c.noii)
))
))
in
(match term ia1, ib with
- | A.Int x, B.Int y ->
+ | A.Int x, B.Int (y,_) ->
X.value_format_flag (fun use_value_equivalence ->
if use_value_equivalence
then
(* todo?: handle some isomorphisms here ? *)
| A.RecordAccess (ea, ia1, ida), ((B.RecordAccess (eb, idb), typ),ii) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- ident DontKnow ida (idb, ib2) >>= (fun ida (idb, ib2) ->
+ 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 ->
return (
((A.RecordAccess (ea, ia1, ida))) +> wa,
- ((B.RecordAccess (eb, idb), typ), [ib1;ib2])
+ ((B.RecordAccess (eb, idb), typ), [ib1])
))))
| A.RecordPtAccess (ea,ia1,ida),((B.RecordPtAccess (eb, idb), typ), ii) ->
- let (ib1, ib2) = tuple_of_list2 ii in
- ident DontKnow ida (idb, ib2) >>= (fun ida (idb, ib2) ->
+ 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 ->
return (
((A.RecordPtAccess (ea, ia1, ida))) +> wa,
- ((B.RecordPtAccess (eb, idb), typ), [ib1;ib2])
+ ((B.RecordPtAccess (eb, idb), typ), [ib1])
))))
-
(* ------------------------------------------------------------------------- *)
+and (ident_cpp: info_ident -> (A.ident, B.name) matcher) =
+ fun infoidb ida idb ->
+ match idb with
+ | B.RegularName (s, iis) ->
+ let iis = tuple_of_list1 iis in
+ ident infoidb ida (s, iis) >>= (fun ida (s,iis) ->
+ return (
+ ida,
+ (B.RegularName (s, [iis]))
+ ))
+ | B.CppConcatenatedName _ | B.CppVariadicName _ |B.CppIdentBuilder _
+ ->
+ (* This should be moved to the Id case of ident. Metavariables
+ should be allowed to be bound to such variables. But doing so
+ would require implementing an appropriate distr function *)
+ fail
+
and (ident: info_ident -> (A.ident, string * Ast_c.info) matcher) =
- fun infoidb ida ((idb, iib) as ib) ->
+ fun infoidb ida ((idb, iib)) -> (* (idb, iib) as ib *)
X.all_bound (A.get_inherited ida) >&&>
match A.unwrap ida with
| A.Id sa ->
))
else fail
-
| A.MetaId(mida,constraints,keep,inherited) ->
- X.check_constraints (ident infoidb) constraints ib
+ X.check_idconstraint satisfies_iconstraint constraints idb
(fun () ->
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
| A.MetaFunc(mida,constraints,keep,inherited) ->
let is_function _ =
- X.check_constraints (ident infoidb) constraints ib
+ X.check_idconstraint satisfies_iconstraint constraints idb
(fun () ->
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)
| A.MetaLocalFunc(mida,constraints,keep,inherited) ->
(match infoidb with
| LocalFunction ->
- X.check_constraints (ident infoidb) constraints ib
+ X.check_idconstraint satisfies_iconstraint constraints idb
(fun () ->
let max_min _ = Lib_parsing_c.lin_col_by_pos [iib] in
X.envf keep inherited
* for the associated ',' see below how we handle the EComma
* to match nothing.
*)
- (if startxs = []
+ (if null startxs
then
if mcode_contain_plus (mcodekind mcode)
then fail
startendxs +> List.fold_left (fun acc (startxs, endxs) ->
acc >||> (
let ok =
- if startxs = []
+ if null startxs
then
if mcode_contain_plus (mcodekind ida)
then false
X.envf keep inherited
(ida, Ast_c.MetaExprListVal startxs', max_min)
(fun () ->
- if startxs = []
+ if null startxs
then return (ida, [])
else X.distrf_args ida (Ast_c.split_comma startxs')
)
and argument arga argb =
X.all_bound (A.get_inherited arga) >&&>
match A.unwrap arga, argb with
- | A.TypeExp tya, Right (B.ArgType (((b, sopt, tyb), ii_b_s))) ->
+ | A.TypeExp tya,
+ Right (B.ArgType {B.p_register=b,iib; p_namei=sopt;p_type=tyb}) ->
if b || sopt <> None
then
(* failwith "the argument have a storage and ast_cocci does not have"*)
fail
else
+ (* b = false and sopt = None *)
fullType tya tyb >>= (fun tya tyb ->
return (
(A.TypeExp tya) +> A.rewrap arga,
- (Right (B.ArgType (((b, sopt, tyb), ii_b_s))))
+ (Right (B.ArgType {B.p_register=(b,iib);
+ p_namei=sopt;
+ p_type=tyb;}))
))
| A.TypeExp tya, _ -> fail
- | _, Right (B.ArgType (tyb, sto_iisto)) -> fail
+ | _, Right (B.ArgType _) -> fail
| _, Left argb ->
expression arga argb >>= (fun arga argb ->
return (arga, Left argb)
startendxs +> List.fold_left (fun acc (startxs, endxs) ->
acc >||> (
- (if startxs = []
+ (if null startxs
then
if mcode_contain_plus (mcodekind mcode)
then fail
startendxs +> List.fold_left (fun acc (startxs, endxs) ->
acc >||> (
let ok =
- if startxs = []
+ if null startxs
then
if mcode_contain_plus (mcodekind ida)
then false
X.envf keep inherited
(ida, Ast_c.MetaParamListVal startxs', max_min)
(fun () ->
- if startxs = []
+ if null startxs
then return (ida, [])
else X.distrf_params ida (Ast_c.split_comma startxs')
) >>= (fun ida startxs ->
| A.VoidParam ta, ys ->
(match eas, ebs with
| [], [Left eb] ->
- let ((hasreg, idbopt, tb), ii_b_s) = eb in
- if idbopt = None && null ii_b_s
+ 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 ->
return (
[(A.VoidParam ta) +> A.rewrap ea],
- [Left ((hasreg, idbopt, tb), ii_b_s)]
+ [Left {B.p_register=(hasreg, iihasreg);
+ p_namei = idbopt;
+ p_type = tb;}]
))
| _ -> fail
else fail
+(*
+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)
+ | _, None, ii -> Right ii
+ | _ -> raise Impossible
+*)
+
+
+and parameter = fun (idaopt, typa) paramb ->
+ let {B.p_register = (hasreg,iihasreg);
+ p_namei = nameidbopt;
+ p_type = typb;} = paramb in
-and parameter = fun (idaopt, typa) ((hasreg, idbopt, typb), ii_b_s) ->
fullType typa typb >>= (fun typa typb ->
- match idaopt, Ast_c.split_register_param (hasreg, idbopt, ii_b_s) with
- | Some ida, Left (idb, iihasreg, iidb) ->
+ match idaopt, nameidbopt with
+ | Some ida, Some nameidb ->
(* todo: if minus on ida, should also minus the iihasreg ? *)
- ident DontKnow ida (idb,iidb) >>= (fun ida (idb,iidb) ->
+ ident_cpp DontKnow ida nameidb >>= (fun ida nameidb ->
return (
(Some ida, typa),
- ((hasreg, Some idb, typb), iihasreg++[iidb])
+ {B.p_register = (hasreg, iihasreg);
+ p_namei = Some (nameidb);
+ p_type = typb}
))
- | None, Right iihasreg ->
+ | None, None ->
return (
(None, typa),
- ((hasreg, None, typb), iihasreg)
+ {B.p_register=(hasreg,iihasreg);
+ p_namei = None;
+ p_type = typb;}
)
)
*)
- | Some _, Right _ -> fail
- | None, Left _ -> fail
+ | Some _, None -> fail
+ | None, Some _ -> fail
)
)))
| _, (B.DeclList (xs, iiptvirgb::iifakestart::iisto)) ->
- if X.mode = PatternMode
+ if X.mode =*= PatternMode
then
xs +> List.fold_left (fun acc var ->
acc >||> (
[iisb;lpb;rpb;iiendb;iifakestart] ++ iistob))
))))))))
- | _, (B.MacroDecl _ |B.DeclList _) -> fail
+ | _, (B.MacroDecl _ |B.DeclList _) -> fail
* T { }; that we want to match against typedef struct { } xx_t;
*)
| A.TyDecl (tya0, ptvirga),
- ({B.v_namei = Some ((idb, None),[iidb]);
+ ({B.v_namei = Some (nameidb, None);
B.v_type = typb0;
B.v_storage = (B.StoTypedef, inl);
B.v_local = local;
B.v_attr = attrs;
+ B.v_type_bis = typb0bis;
}, iivirg) ->
(match A.unwrap tya0, typb0 with
| Some s ->
pr2 (sprintf
"warning: both a typedef (%s) and struct name introduction (%s)"
- idb s
+ (Ast_c.str_of_name nameidb) s
);
pr2 "warning: I will consider only the typedef";
let (iisub, iisb, lbb, rbb) = tuple_of_list4 ii in
(Ast_c.nQ, (B.StructUnion (sub, sbopt, declsb), ii))
in
let fake_typeb =
- Ast_c.nQ,((B.TypeName (idb, Some
- (Lib_parsing_c.al_type structnameb))), [iidb])
+ Ast_c.nQ,((B.TypeName (nameidb, Some
+ (Lib_parsing_c.al_type structnameb))), [])
in
tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
let typb0 = ((qu, il), typb1) in
match fake_typeb with
- | _nQ, ((B.TypeName (idb,_typ)), [iidb]) ->
+ | _nQ, ((B.TypeName (nameidb, _typ)),[]) ->
return (
(A.TyDecl (tya0, ptvirga)) +> A.rewrap decla,
- (({B.v_namei = Some ((idb, None),[iidb]);
+ (({B.v_namei = Some (nameidb, None);
B.v_type = typb0;
B.v_storage = (B.StoTypedef, inl);
B.v_local = local;
B.v_attr = attrs;
+ B.v_type_bis = typb0bis;
},
iivirg),iiptvirgb,iistob)
)
return (
(A.TyDecl (tya0, ptvirga)) +> A.rewrap decla,
- (({B.v_namei = Some ((idb, None),[iidb]);
+ (({B.v_namei = Some (nameidb, None);
B.v_type = typb0;
B.v_storage = (B.StoTypedef, inl);
B.v_local = local;
B.v_attr = attrs;
+ B.v_type_bis = typb0bis;
},
iivirg),iiptvirgb,iistob)
)
)
| A.UnInit (stoa, typa, ida, ptvirga),
- ({B.v_namei = Some ((idb, _),[iidb]);
- B.v_storage = (B.StoTypedef,_);
- }, iivirg) ->
- fail
+ ({B.v_namei= Some (nameidb, _);B.v_storage= (B.StoTypedef,_);}, iivirg)
+ -> fail
| A.Init (stoa, typa, ida, eqa, inia, ptvirga),
- ({B.v_namei = Some ((idb, _),[iidb]);
- B.v_storage = (B.StoTypedef,_);
- }, iivirg) ->
- fail
+ ({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),
- ({B.v_namei = Some ((idb, None),[iidb]);
+ ({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) ->
tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
fullType typa typb >>= (fun typa typb ->
- ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
+ 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 ((idb,None),[iidb]);
+ (({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),
iiptvirgb,iistob)
)))))
| A.Init (stoa, typa, ida, eqa, inia, ptvirga),
- ({B.v_namei = Some((idb,Some inib),[iidb;iieqb]);
+ ({B.v_namei = Some(nameidb, Some (iieqb, inib));
B.v_type = typb;
B.v_storage = stob;
B.v_local = local;
B.v_attr = attrs;
+ 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 DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
+ 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((idb,Some inib),[iidb;iieqb]);
+ (({B.v_namei = Some(nameidb, Some (iieqb, inib));
B.v_type = typb;
B.v_storage = stob;
B.v_local = local;
B.v_attr = attrs;
+ B.v_type_bis = typbbis;
},iivirg),
iiptvirgb,iistob)
)))))))
B.v_storage = stob;
B.v_local = local;
B.v_attr = attrs;
+ B.v_type_bis = typbbis;
}, iivirg) ->
- if stob = (B.NoSto, false)
+ if stob =*= (B.NoSto, false)
then
tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
fullType typa typb >>= (fun typa typb ->
B.v_storage = stob;
B.v_local = local;
B.v_attr = attrs;
+ B.v_type_bis = typbbis;
}, iivirg), iiptvirgb, iistob)
)))
else fail
| A.Typedef (stoa, typa, ida, ptvirga),
- ({B.v_namei = Some ((idb, None),[iidb]);
+ ({B.v_namei = Some (nameidb, None);
B.v_type = typb;
B.v_storage = (B.StoTypedef,inline);
B.v_local = local;
B.v_attr = attrs;
+ B.v_type_bis = typbbis;
},iivirg) ->
tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
| A.MetaType(_,_,_) ->
let fake_typeb =
- Ast_c.nQ, ((B.TypeName (idb, Ast_c.noTypedefDef())), [iidb])
+ Ast_c.nQ, ((B.TypeName (nameidb, Ast_c.noTypedefDef())), [])
in
fullTypebis ida fake_typeb >>= (fun ida fake_typeb ->
match fake_typeb with
- | _nQ, ((B.TypeName (idb,_typ)), [iidb]) ->
- return (ida, (idb, iidb))
+ | _nQ, ((B.TypeName (nameidb, _typ)), []) ->
+ return (ida, nameidb)
| _ -> raise Impossible
)
| A.TypeName sa ->
- if (term sa) =$= idb
- then
- tokenf sa iidb >>= (fun sa iidb ->
- return (
- (A.TypeName sa) +> A.rewrap ida,
- (idb, iidb)
- ))
- else fail
+ (match nameidb with
+ | B.RegularName (sb, iidb) ->
+ let iidb1 = tuple_of_list1 iidb in
+
+ if (term sa) =$= sb
+ then
+ tokenf sa iidb1 >>= (fun sa iidb1 ->
+ return (
+ (A.TypeName sa) +> A.rewrap ida,
+ B.RegularName (sb, [iidb1])
+ ))
+ else fail
+
+ | B.CppConcatenatedName _ | B.CppVariadicName _ |B.CppIdentBuilder _
+ -> raise Todo
+ )
+
| _ -> raise Impossible
- ) >>= (fun ida (idb, iidb) ->
+ ) >>= (fun ida nameidb ->
return (
(A.Typedef (stoa, typa, ida, ptvirga)) +> A.rewrap decla,
- (({B.v_namei = Some ((idb, None),[iidb]);
+ (({B.v_namei = Some (nameidb, None);
B.v_type = typb;
B.v_storage = (B.StoTypedef,inline);
B.v_local = local;
B.v_attr = attrs;
+ B.v_type_bis = typbbis;
},
iivirg),
iiptvirgb, iistob)
| A.OptDecl _, _ | A.UniqueDecl _, _ ->
failwith "not handling Opt/Unique Decl"
- | _, ({B.v_namei=Some _}, _)
- -> fail
+ | _, ({B.v_namei=Some _}, _) ->
+ fail
startendxs +> List.fold_left (fun acc (startxs, endxs) ->
acc >||> (
- (if startxs = []
+ (if null startxs
then
if mcode_contain_plus (mcodekind mcode)
then fail
)
and (struct_field: (A.declaration, B.field) matcher) = fun fa fb ->
- let (xfield, iifield) = fb in
- match xfield with
+ match fb with
| B.DeclarationField (B.FieldDeclList (onefield_multivars,iiptvirg)) ->
let iiptvirgb = tuple_of_list1 iiptvirg in
| [onevar,iivirg] ->
assert (null iivirg);
(match onevar with
- | B.BitField (sopt, typb, expr), ii ->
+ | B.BitField (sopt, typb, _, expr) ->
pr2_once "warning: bitfield not handled by ast_cocci";
fail
- | B.Simple (None, typb), ii ->
+ | B.Simple (None, typb) ->
pr2_once "warning: unamed struct field not handled by ast_cocci";
fail
- | B.Simple (Some idb, typb), ii ->
- let (iidb) = tuple_of_list1 ii in
+ | 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 =
- ({B.v_namei = Some ((idb, None),[iidb]);
+ ({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;
+ (* the struct field should also get expanded ? no it's not
+ * important here, we will rematch very soon *)
},
iivirg)
in
(fun fa (var,iiptvirgb,iisto) ->
match fake_var with
- | ({B.v_namei = Some ((idb, None),[iidb]);
+ | ({B.v_namei = Some (nameidb, None);
B.v_type = typb;
B.v_storage = stob;
}, iivirg) ->
- let onevar = B.Simple (Some idb, typb), [iidb] in
+
+ let onevar = B.Simple (Some nameidb, typb) in
return (
(fa),
((B.DeclarationField
- (B.FieldDeclList ([onevar, iivirg], [iiptvirgb]))),
- iifield)
+ (B.FieldDeclList ([onevar, iivirg], [iiptvirgb])))
+ )
)
| _ -> raise Impossible
)
pr2_once "PB: More that one variable in decl. Have to split";
fail
)
- | B.EmptyField ->
- let _iiptvirgb = tuple_of_list1 iifield in
+ | B.EmptyField _iifield ->
fail
- | B.MacroStructDeclTodo -> fail
+ | B.MacroDeclField _ ->
+ raise Todo
+
| B.CppDirectiveStruct directive -> fail
| B.IfdefStruct directive -> fail
| A.VoidType, B.Void
| A.FloatType, B.FloatType (B.CFloat)
| A.DoubleType, B.FloatType (B.CDouble) ->
- assert (signaopt = None);
+ assert (signaopt =*= None);
let stringa = tuple_of_list1 stringsa in
let (ibaseb) = tuple_of_list1 ii in
tokenf stringa ibaseb >>= (fun stringa ibaseb ->
(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 ->
let match_to_type rebaseb =
sign signaopt signbopt >>= (fun signaopt iisignbopt ->
- let ibaseb = tuple_of_list1 iibaseb in
let fta = A.rewrap basea (A.Type(None,basea)) in
- let ftb = Ast_c.nQ,(B.BaseType (rebaseb), [ibaseb]) in
+ let ftb = Ast_c.nQ,(B.BaseType (rebaseb), iibaseb) in
fullType fta ftb >>= (fun fta (_,tb) ->
(match A.unwrap fta,tb with
A.Type(_,basea), (B.BaseType baseb, ii) ->
- let ibaseb = tuple_of_list1 ii in
return (
(rebuilda (basea, signaopt)) +> A.rewrap ta,
- (B.BaseType (baseb), iisignbopt ++ [ibaseb])
+ (B.BaseType (baseb), iisignbopt ++ ii)
)
| _ -> failwith "not possible"))) in
(match iibaseb with
| [] -> fail (* metavariable has to match something *)
- | [x;y] ->
- pr2_once
- "warning: long int or short int not handled by ast_cocci";
- fail
-
- | [ibaseb] -> match_to_type (B.IntType (B.Si (B.Signed, ty)))
- | _ -> raise Impossible
+ | _ -> match_to_type (B.IntType (B.Si (B.Signed, ty)))
)
* uint in the C code. But some CEs consists in renaming some types,
* so we don't want apply isomorphisms every time.
*)
- | A.TypeName sa, (B.TypeName (sb,typb), ii) ->
- let (isb) = tuple_of_list1 ii in
- if (term sa) =$= sb
- then
- tokenf sa isb >>= (fun sa isb ->
- return (
- (A.TypeName sa) +> A.rewrap ta,
- (B.TypeName (sb,typb), [isb])
- ))
- else fail
+ | A.TypeName sa, (B.TypeName (nameb, typb), noii) ->
+ assert (null noii);
+
+ (match nameb with
+ | B.RegularName (sb, iidb) ->
+ let iidb1 = tuple_of_list1 iidb in
+
+ if (term sa) =$= sb
+ then
+ tokenf sa iidb1 >>= (fun sa iidb1 ->
+ return (
+ (A.TypeName sa) +> A.rewrap ta,
+ (B.TypeName (B.RegularName (sb, [iidb1]), typb), noii)
+ ))
+ else fail
+
+ | B.CppConcatenatedName _ | B.CppVariadicName _ |B.CppIdentBuilder _
+ -> raise Todo
+ )
+
| _, (B.TypeOfExpr e, ii) -> fail
| _, (B.TypeOfType e, ii) -> fail
| _, (B.Enum _, _) -> fail (* todo cocci ?*)
| _,
- ((B.TypeName (_, _) | B.StructUnionName (_, _) | B.EnumName _ |
+ ((B.TypeName _ | B.StructUnionName (_, _) | B.EnumName _ |
B.StructUnion (_, _, _) |
B.FunctionType _ | B.Array (_, _) | B.Pointer _ |
B.BaseType _),
match a, b with
| Type_cocci.VoidType, B.Void ->
- assert (signa = None);
+ 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
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 ->
pr2_once "no longdouble in cocci";
loop (a,b)
| Type_cocci.StructUnionName (sua, _, sa),
(qub, (B.StructUnionName (sub, sb),ii)) ->
- if equal_structUnion_type_cocci sua sub && sa = sb
+ if equal_structUnion_type_cocci sua sub && sa =$= sb
then ok
else fail
| Type_cocci.EnumName (_, sa),
(qub, (B.EnumName (sb),ii)) ->
- if sa = sb
+ if sa =$= sb
then ok
else fail
- | Type_cocci.TypeName sa, (qub, (B.TypeName (sb,_typb), ii)) ->
- if sa = sb
+ | Type_cocci.TypeName sa, (qub, (B.TypeName (namesb, _typb),noii)) ->
+ let sb = Ast_c.str_of_name namesb in
+ if sa =$= sb
then ok
else fail
)
(* subtil: must be after the MetaType case *)
- | a, (qub, (B.TypeName (sb,Some b), ii)) ->
+ | a, (qub, (B.TypeName (_namesb, Some b), noii)) ->
(* kind of typedef iso *)
loop (a,b)
| _, None -> false
)
- | (A.IncPath x)::xs, y::ys -> x = y && aux_inc (xs, ys) (x::passed)
+ | (A.IncPath x)::xs, y::ys -> x =$= y && aux_inc (xs, ys) (x::passed)
| _ -> failwith "IncDots not in last place or other pb"
in
startendxs +> List.fold_left (fun acc (startxs, endxs) ->
acc >||> (
- (if startxs = []
+ (if null startxs
then
if mcode_contain_plus (mcodekind mcode)
then fail
let default = A.MetaRuleElem(mcode,keep,inherited), unwrap_node in
(match unwrap_node with
| F.CaseNode _
- | F.TrueNode | F.FalseNode | F.AfterNode | F.FallThroughNode
+ | F.TrueNode | F.FalseNode | F.AfterNode
+ | F.LoopFallThroughNode | F.FallThroughNode
| F.InLoopNode ->
- if X.mode = PatternMode
+ if X.mode =*= PatternMode
then return default
else
if mcode_contain_plus (mcodekind mcode)
else return default
| F.EndStatement None ->
- if X.mode = PatternMode then return default
+ 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)
))
| F.FunHeader _ ->
- if X.mode = PatternMode then return default
+ if X.mode =*= PatternMode then return default
else failwith "a MetaRuleElem can't transform a headfunc"
| _n ->
- if X.mode = PatternMode then return default
+ if X.mode =*= PatternMode then return default
else
X.distrf_node (generalize_mcode mcode) node >>= (fun mcode node ->
return (
* TODO: and F.Fake ?
*)
| _, F.EndStatement _ | _, F.CaseNode _
- | _, F.TrueNode | _, F.FalseNode | _, F.AfterNode | _, F.FallThroughNode
+ | _, F.TrueNode | _, F.FalseNode | _, F.AfterNode
+ | _, F.FallThroughNode | _, F.LoopFallThroughNode
| _, F.InLoopNode
-> fail2()
| A.FunHeader (mckstart, allminus, fninfoa, ida, oparen, paramsa, cparen),
- F.FunHeader ({B.f_name = idb;
+ F.FunHeader ({B.f_name = nameidb;
f_type = (retb, (paramsb, (isvaargs, iidotsb)));
f_storage = stob;
f_attr = attrs;
with [A.FAttr(a)] -> failwith "not checking attributes" | _ -> ());
(match ii with
- | iidb::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 LocalFunction ida (idb, iidb) >>= (fun ida (idb, iidb) ->
+ 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 ->
return (
A.FunHeader(mckstart,allminus,fninfoa,ida,oparen,
paramsa,cparen),
- F.FunHeader ({B.f_name = idb;
+ F.FunHeader ({B.f_name = nameidb;
f_type = (retb, (paramsb, (isvaargs, iidotsb)));
f_storage = stob;
f_attr = attrs;
f_body = body;
f_old_c_style = oldstyle; (* TODO *)
},
- iidb::ioparenb::icparenb::iifakestart::iistob)
+ ioparenb::icparenb::iifakestart::iistob)
)
))))))))
| _ -> raise Impossible
B.i_is_in_ifdef = inifdef;
B.i_content = copt;
} ->
- assert (copt = None);
+ assert (copt =*= None);
let include_requirment =
match mcodekind incla, mcodekind filea with
| _, F.ExprStatement (_, (None, ii)) -> fail (* happen ? *)
- | A.Label(id,dd), F.Label (st,(s,ii)) ->
- let (ib1,ib2) = tuple_of_list2 ii in
- let (string_of_id,rebuild) =
- match A.unwrap id with
- A.Id(s) -> (s,function s -> A.rewrap id (A.Id(s)))
- | _ -> failwith "labels with metavariables not supported" in
- if (term string_of_id) =$= s
- then
- tokenf string_of_id ib1 >>= (fun string_of_id ib1 ->
- tokenf dd ib2 >>= (fun dd ib2 ->
- return (
- A.Label(rebuild string_of_id,dd),
- F.Label (st,(s,[ib1;ib2]))
- )))
- else fail
+ | A.Label(id,dd), F.Label (st, nameb, ((),ii)) ->
+ let (ib2) = tuple_of_list1 ii in
+ ident_cpp DontKnow id nameb >>= (fun ida nameb ->
+ tokenf dd ib2 >>= (fun dd ib2 ->
+ return (
+ A.Label (ida,dd),
+ F.Label (st,nameb, ((),[ib2]))
+ )))
- | A.Goto(goto,id,sem), F.Goto (st,(s,ii)) ->
- let (ib1,ib2,ib3) = tuple_of_list3 ii in
+ | A.Goto(goto,id,sem), F.Goto (st,nameb, ((),ii)) ->
+ let (ib1,ib3) = tuple_of_list2 ii in
tokenf goto ib1 >>= (fun goto ib1 ->
- ident DontKnow id (s, ib2) >>= (fun id (s, ib2) ->
+ ident_cpp DontKnow id nameb >>= (fun id nameb ->
tokenf sem ib3 >>= (fun sem ib3 ->
return(
A.Goto(goto,id,sem),
- F.Goto (st,(s,[ib1;ib2;ib3]))
+ F.Goto (st,nameb, ((),[ib1;ib3]))
))))
(* have not a counter part in coccinelle, for the moment *)
(F.MacroStmt (_, _)| F.DefineDoWhileZeroHeader _| F.EndNode|F.TopNode)
-> fail
| _,
- (F.Label (_, _)|F.Break (_, _)|F.Continue (_, _)|F.Default (_, _)|
+ (F.Label (_, _, _)|F.Break (_, _)|F.Continue (_, _)|F.Default (_, _)|
F.Case (_, _)|F.Include _|F.Goto _|F.ExprStatement _|
F.DefineType _|F.DefineExpr _|F.DefineTodo|
F.DefineHeader (_, _)|F.ReturnExpr (_, _)|F.Return (_, _)|F.MacroIterHeader (_, _)|
HCoop / bpt / coccinelle.git / blobdiff