+++ /dev/null
-(*
-* Copyright 2005-2008, 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.
-*)
-
-
-open Common
-
-module A = Ast_cocci
-module B = Ast_c
-
-module F = Control_flow_c
-
-(*****************************************************************************)
-(* Wrappers *)
-(*****************************************************************************)
-
-(*****************************************************************************)
-(* Helpers *)
-(*****************************************************************************)
-
-type sequence = Ordered | 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 ->
- 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) ->
- match B.unwrap ib with
- | B.InitDesignators _
- | B.InitFieldOld _
- | B.InitIndexOld _
- -> true
- | B.InitExpr _
- | B.InitList _
- -> false
- )
-
-(* For the #include <linux/...> in the .cocci, need to find where is
- * the '+' attached to this element, to later find the first concrete
- * #include <linux/xxx.h> or last one in the serie of #includes in the
- * .c.
- *)
-type include_requirement =
- | IncludeMcodeBefore
- | IncludeMcodeAfter
- | IncludeNothing
-
-
-
-(* todo? put in semantic_c.ml *)
-type info_ident =
- | Function
- | LocalFunction (* entails Function *)
- | DontKnow
-
-
-let term mc = A.unwrap_mcode mc
-let mcodekind mc = A.get_mcodekind mc
-
-
-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
-
-let mcode_simple_minus = function
- | A.MINUS (_,[]) -> true
- | _ -> false
-
-
-(* In transformation.ml sometime I build some mcodekind myself and
- * julia has put None for the pos. But there is no possible raise
- * NoMatch in those cases because it is for the minusall trick or for
- * the distribute, so either have to build those pos, in fact a range,
- * because for the distribute have to erase a fullType with one
- * 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"),
- {A.line = 0; column =0; A.strbef=[]; A.straft=[];},
- (A.MINUS(A.DontCarePos, [])),
- A.NoMetaPos
-
-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.DontCarePos,x)
- | A.MINUS (A.NoPos,x) ->
- A.MINUS (A.DontCarePos,x)
- | _ -> raise Impossible in
- (s1, i, new_mck, pos)
-
-
-
-(*---------------------------------------------------------------------------*)
-
-(* 0x0 is equivalent to 0, value format isomorphism *)
-let equal_c_int s1 s2 =
- try
- int_of_string s1 = int_of_string s2
- 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.
- *)
-
-let equal_unaryOp a b =
- match a, b with
- | A.GetRef , B.GetRef -> true
- | A.DeRef , B.DeRef -> true
- | A.UnPlus , B.UnPlus -> true
- | A.UnMinus , B.UnMinus -> true
- | A.Tilde , B.Tilde -> true
- | A.Not , B.Not -> true
- | _, _ -> false
-
-let equal_arithOp a b =
- match a, b with
- | A.Plus , B.Plus -> true
- | A.Minus , B.Minus -> true
- | A.Mul , B.Mul -> true
- | A.Div , B.Div -> true
- | A.Mod , B.Mod -> true
- | A.DecLeft , B.DecLeft -> true
- | A.DecRight , B.DecRight -> true
- | A.And , B.And -> true
- | A.Or , B.Or -> true
- | A.Xor , B.Xor -> true
- | _ , _ -> false
-
-let equal_logicalOp a b =
- match a, b with
- | A.Inf , B.Inf -> true
- | A.Sup , B.Sup -> true
- | A.InfEq , B.InfEq -> true
- | A.SupEq , B.SupEq -> true
- | A.Eq , B.Eq -> true
- | A.NotEq , B.NotEq -> true
- | A.AndLog , B.AndLog -> true
- | A.OrLog , B.OrLog -> true
- | _ , _ -> false
-
-let equal_assignOp a b =
- match a, b with
- | A.SimpleAssign, B.SimpleAssign -> true
- | A.OpAssign a, B.OpAssign b -> equal_arithOp a b
- | _ -> false
-
-let equal_fixOp a b =
- match a, b with
- | A.Dec, B.Dec -> true
- | A.Inc, B.Inc -> true
- | _ -> false
-
-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
- | _ -> false
-
-let equal_structUnion a b =
- match a, b with
- | A.Struct, B.Struct -> true
- | A.Union, B.Union -> true
- | _, _ -> false
-
-let equal_sign a b =
- match a, b with
- | A.Signed, B.Signed -> true
- | A.Unsigned, B.UnSigned -> true
- | _, _ -> false
-
-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
- -> true
- | _ -> false
-
-(*---------------------------------------------------------------------------*)
-
-let equal_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_expr a =*= Lib_parsing_c.al_expr 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 ->
- Lib_parsing_c.al_statement a =*= Lib_parsing_c.al_statement 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 ->
- 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,posa1,posa2) ->
- List.exists
- (function (flb,posb1,posb2) ->
- fla = flb &&
- Ast_c.equal_posl posa1 posb1 && Ast_c.equal_posl posa2 posb2)
- l2)
- l1
- | _ -> raise Impossible
-
-
-
-(*---------------------------------------------------------------------------*)
-(* could put in ast_c.ml, next to the split/unsplit_comma *)
-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]
-
-
- | 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"
-
-(*---------------------------------------------------------------------------*)
-
-let rec unsplit_icomma xs =
- match xs with
- | [] -> []
- | x::y::xs ->
- (match A.unwrap y with
- | 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 =
- match iicomma, ibs with
- | [], [] -> []
- | [], _ ->
- failwith "should have a iicomma, do you generate fakeInfo in parser?"
- | _, [] ->
- failwith "shouldn't have a iicomma"
- | [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
- | _ -> raise Impossible
-
-
-
-let rec split_icomma xs =
- match xs with
- | [] -> []
- | (x,y)::xs -> x::y::split_icomma xs
-
-let rec unsplit_initialiser ibs_unsplit =
- match ibs_unsplit with
- | [] -> [], [] (* empty iicomma *)
- | (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 ->
- 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) ->
- (match sopt,iis with
- | Some s , [i1;i2;i3;i4] ->
- qu, (B.StructUnionName (su, s), [i1;i2])
- | None, _ ->
- ty
-
- | x -> raise Impossible
- )
- | _ -> raise Impossible
-
-(*---------------------------------------------------------------------------*)
-let initialisation_to_affectation decl =
- match decl with
- | B.MacroDecl _ -> F.Decl decl
- | 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] ->
- let ((var, returnType, storage, local),iisep) = x in
-
- (match var with
- | Some ((s, ini), iis::iini) ->
- (match ini with
- | Some (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
-
- let typ =
- ref (Some ((Lib_parsing_c.al_type returnType),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)
- | _ -> F.Decl decl
- )
- | _ -> F.Decl decl
- )
- | 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
- * ExprStatement from that.
- *)
- F.Decl decl
- )
-
-
-
-
-
-(*****************************************************************************)
-(* Functor parameter combinators *)
-(*****************************************************************************)
-(* 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 (>>=):
- * (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
- type tin
- type 'x tout
-
-
- type ('a, 'b) matcher = 'a -> 'b -> tin -> ('a * 'b) tout
-
- val mode : mode
-
- 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 (>||>) :
- (tin -> 'x tout) ->
- (tin -> 'x tout) ->
- (tin -> 'x tout)
-
- val (>|+|>) :
- (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 :
- (A.meta_name A.mcode, B.expression) matcher
- val distrf_args :
- (A.meta_name A.mcode, (Ast_c.argument, Ast_c.il) either list) matcher
- val distrf_type :
- (A.meta_name A.mcode, Ast_c.fullType) matcher
- val distrf_params :
- (A.meta_name A.mcode,
- (Ast_c.parameterType, Ast_c.il) either list) matcher
- val distrf_param :
- (A.meta_name A.mcode, Ast_c.parameterType) matcher
- val distrf_ini :
- (A.meta_name A.mcode, Ast_c.initialiser) matcher
- val distrf_node :
- (A.meta_name A.mcode, Control_flow_c.node) matcher
-
- val distrf_define_params :
- (A.meta_name A.mcode, (string Ast_c.wrap, Ast_c.il) either list)
- matcher
-
- val distrf_struct_fields :
- (A.meta_name A.mcode, B.field B.wrap list) matcher
-
- val distrf_cst :
- (A.meta_name A.mcode, (B.constant, string) either B.wrap) matcher
-
- val cocciExp :
- (A.expression, B.expression) matcher -> (A.expression, F.node) matcher
-
- val cocciExpExp :
- (A.expression, B.expression) matcher ->
- (A.expression, B.expression) matcher
-
- val cocciTy :
- (A.fullType, B.fullType) matcher -> (A.fullType, F.node) matcher
-
- val cocciInit :
- (A.initialiser, B.initialiser) matcher -> (A.initialiser, F.node) matcher
-
- val envf :
- A.keep_binding -> A.inherited ->
- A.meta_name A.mcode * Ast_c.metavar_binding_kind *
- (unit -> Common.filename * Ast_c.posl * Ast_c.posl) ->
- (unit -> tin -> 'x tout) -> (tin -> 'x tout)
-
- val check_constraints :
- ('a, 'b) matcher -> 'a list -> 'b ->
- (unit -> tin -> 'x tout) -> (tin -> 'x tout)
-
- val all_bound : A.meta_name list -> (tin -> bool)
-
- val optional_storage_flag : (bool -> tin -> 'x tout) -> (tin -> 'x tout)
- val optional_qualifier_flag : (bool -> tin -> 'x tout) -> (tin -> 'x tout)
- val value_format_flag: (bool -> tin -> 'x tout) -> (tin -> 'x tout)
-
-
- end
-
-(*****************************************************************************)
-(* Functor code, "Cocci vs C" *)
-(*****************************************************************************)
-
-module COCCI_VS_C =
- functor (X : PARAM) ->
-struct
-
-type ('a, 'b) matcher = 'a -> 'b -> X.tin -> ('a * 'b) X.tout
-
-let (>>=) = X.(>>=)
-let return = X.return
-let fail = X.fail
-
-let (>||>) = X.(>||>)
-let (>|+|>) = X.(>|+|>)
-let (>&&>) = X.(>&&>)
-
-let tokenf = X.tokenf
-
-(* should be raise Impossible when called from transformation.ml *)
-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 ->
- return (Some t1, Some t2)
- )
- | (None, None) -> return (None, None)
- | _ -> fail
-
-(* Dots are sometimes used as metavariables, since like metavariables they
-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 metavar2dots (_,info,mcodekind,pos) = ("...",info,mcodekind,pos)
-
-(*---------------------------------------------------------------------------*)
-(* toc:
- * - expression
- * - ident
- * - arguments
- * - parameters
- * - declaration
- * - initialisers
- * - type
- * - node
- *)
-
-(*---------------------------------------------------------------------------*)
-let rec (expression: (A.expression, Ast_c.expression) matcher) =
- fun ea eb ->
- 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
- * differentiate between different cases *)
- let rec matches_id = function
- B.Ident(c) -> true
- | B.Cast(ty,e) -> matches_id (B.unwrap_expr e)
- | _ -> false in
- let form_ok =
- match (form,expr) with
- (A.ANY,_) -> true
- | (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.Cast(ty,e) -> matches (B.unwrap_expr e)
- | B.Unary(e,B.UnMinus) -> matches (B.unwrap_expr e)
- | B.SizeOfExpr(exp) -> true
- | B.SizeOfType(ty) -> true
- | _ -> false in
- matches e
- | (A.LocalID,e) ->
- (matches_id e) &&
- (match !opttypb with
- (Some (_,Ast_c.LocalVar _),_) -> true
- | _ -> false)
- | (A.ID,e) -> matches_id e in
-
- if form_ok
- then
- (let (opttypb,_testb) = !opttypb in
- match opttypa, opttypb with
- | None, _ -> return ((),())
- | Some _, None ->
- pr2_once ("Missing type information. Certainly a pb in " ^
- "annotate_typer.ml");
- fail
-
- | 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
- ))
- )))
- else fail
-
- (* 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 ...>)
- *)
- | A.Edots (mcode, None), expb ->
- X.distrf_e (dots2metavar mcode) expb >>= (fun mcode expb ->
- return (
- A.Edots (metavar2dots mcode, None) +> A.rewrap ea ,
- expb
- ))
-
-
- | 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) ->
- return (
- ((A.Ident ida)) +> wa,
- ((B.Ident idb, typ),[ib1])
- ))
-
-
-
-
- | 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
- *)
- | 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,
- ((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
- if equal_c_int x y
- then do1()
- else fail
- else
- if x =$= y
- then do1()
- else fail
- )
- | A.Char x, B.Char (y,_) when x =$= y (* todo: use kind ? *)
- -> do1()
- | A.Float x, B.Float (y,_) when x =$= y (* todo: use floatType ? *)
- -> do1()
-
- | 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,
- ((B.Constant (ib), typ),[ib1])
- ))
- | _ -> fail (* multi string, not handled *)
- )
- | _, _ -> fail
- )
-
-
- | 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.
- *)
- 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 ->
- arguments (seqstyle eas) (A.undots eas) ebs >>= (fun easundots ebs ->
- let eas = redots eas easundots in
- return (
- ((A.FunCall (ea, ia1, eas, ia2)) +> wa,
- ((B.FunCall (eb, ebs),typ), [ib1;ib2])
- ))))))
-
-
-
-
- | A.Assignment (ea1, opa, ea2, simple),
- ((B.Assignment (eb1, opb, eb2), typ),ii) ->
- let (opbi) = tuple_of_list1 ii in
- 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 ->
- return (
- ((A.Assignment (ea1, opa, ea2, simple))) +> wa,
- ((B.Assignment (eb1, opb, eb2), typ), [opbi])
- ))))
- else fail
-
- | 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 ->
- 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) ->
- 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 ->
- return (
- ((A.Postfix (ea, opa))) +> wa,
- ((B.Postfix (eb, opb), typ),[opbi])
- )))
- else fail
-
-
- | 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 ->
- return (
- ((A.Infix (ea, opa))) +> wa,
- ((B.Infix (eb, opb), typ),[opbi])
- )))
- else fail
-
- | 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 ->
- 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) ->
- 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 ->
- return (
- ((A.Binary (ea1, opa, ea2))) +> wa,
- ((B.Binary (eb1, opb, eb2), typ),[opbi]
- )))))
- else fail
-
- | 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) >|+|>
- (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 ->
- 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 ->
- 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 ->
- 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 ->
- return (
- ((A.Nested (ea1, opa, ea2))) +> wa,
- ((B.Binary (eb1, opb, eb2), typ),[opbi]
- )))))) in
- left_to_right >|+|> right_to_left >|+|> in_left >|+|> in_right
- | _ -> fail) in
- loop eb
-
- (* todo?: handle some isomorphisms here ? (with pointers = Unary Deref) *)
- | 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 ->
- 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, ib2) = tuple_of_list2 ii in
- ident DontKnow ida (idb, ib2) >>= (fun ida (idb, ib2) ->
- 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])
- ))))
-
-
-
- | 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) ->
- 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])
- ))))
-
-
- (* 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) ->
- 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 ->
- return (
- ((A.Cast (ia1, typa, ia2, ea))) +> wa,
- ((B.Cast (typb, eb),typ),[ib1;ib2])
- )))))
-
- | 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 ->
- return (
- ((A.SizeOfExpr (ia1, ea))) +> wa,
- ((B.SizeOfExpr (eb), typ),[ib1])
- )))
-
- | 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 ->
- 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) ->
- 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 ->
- return (
- ((A.Paren (ia1, ea, ia2))) +> wa,
- ((B.ParenExpr (eb), typ), [ib1;ib2])
- ))))
-
- | A.NestExpr(exps,None,true), eb ->
- (match A.unwrap exps with
- A.DOTS [exp] ->
- X.cocciExpExp expression exp eb >>= (fun exp eb ->
- return (
- (A.NestExpr(A.rewrap exps (A.DOTS [exp]),None,true)) +> wa,
- eb
- )
- )
- | _ ->
- failwith
- "for nestexpr, only handling the case with dots and only one exp")
-
- | A.NestExpr _, _ ->
- failwith "only handling multi and no when code in a nest expr"
-
- (* only in arg lists or in define body *)
- | A.TypeExp _, _ -> fail
-
- (* only in arg lists *)
- | A.MetaExprList _, _
- | A.EComma _, _
- | A.Ecircles _, _
- | A.Estars _, _
- ->
- raise Impossible
-
- | A.DisjExpr eas, eb ->
- eas +> List.fold_left (fun acc ea -> acc >|+|> (expression ea eb)) fail
-
- | 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 _,_),_)
- -> fail
-
- | _, _ -> fail
-
-
-
-(* ------------------------------------------------------------------------- *)
-and (ident: info_ident -> (A.ident, string * Ast_c.info) matcher) =
- fun infoidb ida ((idb, iib) as ib) ->
- X.all_bound (A.get_inherited ida) >&&>
- match A.unwrap ida with
- | A.Id sa ->
- if (term sa) =$= idb then
- 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_constraints (ident infoidb) constraints ib
- (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
- 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 ->
- return (
- ((A.MetaId (mida, constraints, keep, inherited)) +> A.rewrap ida,
- (idb, iib)
- )))
- ))
-
- | A.MetaFunc(mida,constraints,keep,inherited) ->
- let is_function _ =
- X.check_constraints (ident infoidb) constraints ib
- (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)
- (fun () ->
- tokenf mida iib >>= (fun mida iib ->
- return (
- ((A.MetaFunc(mida,constraints,keep,inherited)))+>A.rewrap ida,
- (idb, iib)
- ))
- )) in
- (match infoidb with
- | LocalFunction | Function -> is_function()
- | DontKnow ->
- failwith "MetaFunc, need more semantic info about id"
- (* the following implementation could possibly be useful, if one
- follows the convention that a macro is always in capital letters
- and that a macro is not a function.
- (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_constraints (ident infoidb) constraints ib
- (fun () ->
- 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 ->
- return (
- ((A.MetaLocalFunc(mida,constraints,keep,inherited)))
- +> A.rewrap ida,
- (idb, iib)
- ))
- ))
- | Function -> fail
- | DontKnow -> failwith "MetaLocalFunc, need more semantic info about id"
- )
-
- | 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) =
- 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 ->
- return (eas, (Ast_c.unsplit_comma ebs_splitted))
- )
-(* 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
- * some combinators to help ?
- * update: with the tag-SP approach, no more a problem.
- *)
-
-and arguments_bis = fun eas ebs ->
- match eas, ebs with
- | [], [] -> return ([], [])
- | [], eb::ebs -> fail
- | ea::eas, ebs ->
- X.all_bound (A.get_inherited ea) >&&>
- (match A.unwrap ea, ebs with
- | 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) ->
- acc >||> (
-
- (* allow '...', and maybe its associated ',' to match nothing.
- * for the associated ',' see below how we handle the EComma
- * to match nothing.
- *)
- (if startxs = []
- then
- if mcode_contain_plus (mcodekind mcode)
- then fail
- (* failwith "I have no token that I could accroche myself on" *)
- else return (dots2metavar mcode, [])
- else
- (* subtil: we dont want the '...' to match until the
- * comma. cf -test pb_params_iso. We would get at
- * "already tagged" error.
- * this is because both f (... x, ...) and f (..., x, ...)
- * would match a f(x,3) with our "optional-comma" strategy.
- *)
- (match Common.last startxs with
- | Right _ -> fail
- | Left _ ->
- X.distrf_args (dots2metavar mcode) startxs
- )
- )
- >>= (fun mcode startxs ->
- let mcode = metavar2dots mcode in
- arguments_bis eas endxs >>= (fun eas endxs ->
- return (
- (A.Edots (mcode, optexpr) +> A.rewrap ea) ::eas,
- startxs ++ endxs
- )))
- )
- ) fail
-
- | 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 ->
- return (
- (A.EComma ia1 +> A.rewrap ea)::eas,
- (Right [ib1])::ebs
- )
- ))
- | A.EComma ia1, ebs ->
- (* allow ',' to maching nothing. optional comma trick *)
- if mcode_contain_plus (mcodekind ia1)
- then fail
- else arguments_bis eas ebs
-
- | 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) ->
- acc >||> (
- let ok =
- if startxs = []
- then
- if mcode_contain_plus (mcodekind ida)
- then false
- (* failwith "no token that I could accroche myself on" *)
- else true
- else
- (match Common.last startxs with
- | Right _ -> false
- | Left _ -> true
- )
- in
- if not ok
- then fail
- else
- let startxs' = Ast_c.unsplit_comma startxs in
- let len = List.length startxs' in
-
- (match leninfo with
- | Some (lenname,lenkeep,leninherited) ->
- let max_min _ = failwith "no pos" in
- X.envf lenkeep leninherited
- (lenname, Ast_c.MetaListlenVal (len), max_min)
- | None -> function f -> f()
- )
- (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 () ->
- if startxs = []
- then return (ida, [])
- else X.distrf_args ida (Ast_c.split_comma startxs')
- )
- >>= (fun ida startxs ->
- arguments_bis eas endxs >>= (fun eas endxs ->
- return (
- (A.MetaExprList(ida,leninfo,keep,inherited))
- +> A.rewrap ea::eas,
- startxs ++ endxs
- ))
- )
- )
- )) fail
-
-
- | _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, Right (B.ArgType (((b, sopt, tyb), ii_b_s))) ->
-
- if b || sopt <> None
- then
- (* failwith "the argument have a storage and ast_cocci does not have"*)
- fail
- else
- fullType tya tyb >>= (fun tya tyb ->
- return (
- (A.TypeExp tya) +> A.rewrap arga,
- (Right (B.ArgType (((b, sopt, tyb), ii_b_s))))
- ))
-
- | A.TypeExp tya, _ -> fail
- | _, Right (B.ArgType (tyb, sto_iisto)) -> fail
- | _, Left argb ->
- expression arga argb >>= (fun arga argb ->
- return (arga, Left argb)
- )
- | _, Right (B.ArgAction y) -> fail
-
-
-(* ------------------------------------------------------------------------- *)
-(* todo? facto code with argument ? *)
-and (parameters: sequence ->
- (A.parameterTypeDef list, Ast_c.parameterType Ast_c.wrap2 list)
- 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 ->
- return (eas, (Ast_c.unsplit_comma ebs_splitted))
- )
-
-
-and parameters_bis eas ebs =
- match eas, ebs with
- | [], [] -> return ([], [])
- | [], eb::ebs -> fail
- | ea::eas, ebs ->
- (* the management of positions is inlined into each case, because
- 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 ->
-
- (* '...' 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) ->
- acc >||> (
-
- (if startxs = []
- then
- if mcode_contain_plus (mcodekind mcode)
- then fail
- (* failwith "I have no token that I could accroche myself on"*)
- else return (dots2metavar mcode, [])
- else
- (match Common.last startxs with
- | Right _ -> fail
- | Left _ ->
- X.distrf_params (dots2metavar mcode) startxs
- )
- ) >>= (fun mcode startxs ->
- let mcode = metavar2dots mcode in
- parameters_bis eas endxs >>= (fun eas endxs ->
- return (
- (A.Pdots (mcode) +> A.rewrap ea) ::eas,
- startxs ++ endxs
- )))
- )
- ) fail
-
- | 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 ->
- return (
- (A.PComma ia1 +> A.rewrap ea)::eas,
- (Right [ib1])::ebs
- )
- ))
-
- | A.PComma ia1, ebs ->
- (* try optional comma trick *)
- if mcode_contain_plus (mcodekind ia1)
- then fail
- else parameters_bis eas ebs
-
-
- | 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) ->
- acc >||> (
- let ok =
- if startxs = []
- then
- if mcode_contain_plus (mcodekind ida)
- then false
- (* failwith "I have no token that I could accroche myself on" *)
- else true
- else
- (match Common.last startxs with
- | Right _ -> false
- | Left _ -> true
- )
- in
- if not ok
- then fail
- else
- let startxs' = Ast_c.unsplit_comma startxs in
- let len = List.length startxs' in
-
- (match leninfo with
- Some (lenname,lenkeep,leninherited) ->
- let max_min _ = failwith "no pos" in
- X.envf lenkeep leninherited
- (lenname, Ast_c.MetaListlenVal (len), max_min)
- | None -> function f -> f()
- )
- (fun () ->
- let max_min _ =
- Lib_parsing_c.lin_col_by_pos
- (Lib_parsing_c.ii_of_params startxs) in
- X.envf keep inherited
- (ida, Ast_c.MetaParamListVal startxs', max_min)
- (fun () ->
- if startxs = []
- then return (ida, [])
- else X.distrf_params ida (Ast_c.split_comma startxs')
- ) >>= (fun ida startxs ->
- parameters_bis eas endxs >>= (fun eas endxs ->
- return (
- (A.MetaParamList(ida,leninfo,keep,inherited))
- +> A.rewrap ea::eas,
- startxs ++ endxs
- ))
- )
- ))
- ) fail
-
-
- | 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
- 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)]
- ))
- | _ -> fail
- else fail
- | _ -> fail
- )
-
- | (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 ->
- (* 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.distrf_param ida eb
- ) >>= (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 ->
- (*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 ->
- return (
- (A.Param (typa, idaopt))+> A.rewrap ea :: eas,
- (Left eb)::ebs
- )))
-
- | _unwrapx, (Right y)::ys -> raise Impossible
- | _unwrapx, [] -> fail
- )
-
-
-
-
-
-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) ->
- (* todo: if minus on ida, should also minus the iihasreg ? *)
- ident DontKnow ida (idb,iidb) >>= (fun ida (idb,iidb) ->
- return (
- (Some ida, typa),
- ((hasreg, Some idb, typb), iihasreg++[iidb])
- ))
-
- | None, Right iihasreg ->
- return (
- (None, typa),
- ((hasreg, None, typb), iihasreg)
- )
-
-
- (* 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 ?
- *)
- (* not anymore !!! now that julia is handling the proto.
- | _, Right iihasreg ->
- return (
- (idaopt, typa),
- ((hasreg, None, typb), iihasreg)
- )
- *)
-
- | Some _, Right _ -> fail
- | None, Left _ -> fail
- )
-
-
-
-
-(* ------------------------------------------------------------------------- *)
-and (declaration: (A.mcodekind * bool * A.declaration,B.declaration) matcher) =
- fun (mckstart, allminus, decla) declb ->
- X.all_bound (A.get_inherited decla) >&&>
- match A.unwrap decla, declb with
-
- (* Un MetaDecl est introduit dans l'asttoctl pour sauter au dessus
- * de toutes les declarations qui sont au debut d'un fonction et
- * 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.
- *)
-
- | A.MetaDecl(ida,_keep,_inherited), _ -> (* keep ? inherited ? *)
- (* todo: should not happen in transform mode *)
- return ((mckstart, allminus, decla), declb)
-
-
-
- | _, (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 ->
- return (
- (mckstart, allminus, decla),
- (B.DeclList ([var], iiptvirgb::iifakestart::iisto))
- )))
-
- | _, (B.DeclList (xs, iiptvirgb::iifakestart::iisto)) ->
- if X.mode = PatternMode
- then
- 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) ->
- return (
- (mckstart, allminus, decla),
- (B.DeclList ([var], iiptvirgb::iifakestart::iisto))
- )))))
- fail
- 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) =
- (match ii with
- | iisb::lpb::rpb::iiendb::iifakestart::iisto ->
- (iisb,lpb,rpb,iiendb, iifakestart,iisto)
- | _ -> raise Impossible
- ) in
- (if allminus
- then minusize_list iistob
- else return ((), iistob)
- ) >>= (fun () iistob ->
-
- 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 ->
- let eas = redots eas easundots in
-
- return (
- (mckstart, allminus,
- (A.MacroDecl (sa,lpa,eas,rpa,enda)) +> A.rewrap decla),
- (B.MacroDecl ((sb,ebs),
- [iisb;lpb;rpb;iiendb;iifakestart] ++ iistob))
- ))))))))
-
- | _ -> fail
-
-
-
-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
- * T { }; that we want to match against typedef struct { } xx_t;
- *)
- | A.TyDecl (tya0, ptvirga),
- ((Some ((idb, None),[iidb]), typb0, (B.StoTypedef, inl), local), iivirg) ->
-
- (match A.unwrap tya0, typb0 with
- | 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) ->
-
- let (iisub, iisbopt, lbb, rbb) =
- match sbopt with
- | None ->
- let (iisub, lbb, rbb) = tuple_of_list3 ii in
- (iisub, [], lbb, rbb)
- | Some s ->
- pr2 (sprintf
- "warning: both a typedef (%s) and struct name introduction (%s)"
- idb s
- );
- pr2 "warning: I will consider only the typedef";
- let (iisub, iisb, lbb, rbb) = tuple_of_list4 ii in
- (iisub, [iisb], lbb, rbb)
- in
- let structnameb =
- structdef_to_struct_name
- (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])
- in
-
- 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) ->
- (match A.unwrap tya3 with
- | A.MetaType(ida,keep, inherited) ->
-
- 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 (idb,_typ)), [iidb]) ->
-
- return (
- (A.TyDecl (tya0, ptvirga)) +> A.rewrap decla,
- (((Some ((idb, None),[iidb]), typb0, (B.StoTypedef, inl),
- local),
- iivirg),iiptvirgb,iistob)
- )
- | _ -> raise Impossible
- )
-
- | A.StructUnionName(sua, sa) ->
-
- 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
- | _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,
- (((Some ((idb, None),[iidb]), typb0,
- (B.StoTypedef, inl), local),
- iivirg),iiptvirgb,iistob)
- )
- | _ -> raise Impossible
- )
- | _ -> raise Impossible
- )
- | _ -> fail
- )))))
- | _ -> fail
- )
- | _ -> fail
- )
-
- | A.UnInit (stoa, typa, ida, ptvirga),
- ((Some ((idb, _),[iidb]), typb, (B.StoTypedef,_), _local), iivirg) ->
- fail
-
- | A.Init (stoa, typa, ida, eqa, inia, ptvirga),
- ((Some ((idb, _),[iidb]), typb, (B.StoTypedef,_), _local), iivirg) ->
- fail
-
-
-
- (* could handle iso here but handled in standard.iso *)
- | A.UnInit (stoa, typa, ida, ptvirga),
- ((Some ((idb, None),[iidb]), typb, stob, local), iivirg) ->
- tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
- fullType typa typb >>= (fun typa typb ->
- ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
- storage_optional_allminus allminus stoa (stob, iistob) >>=
- (fun stoa (stob, iistob) ->
- return (
- (A.UnInit (stoa, typa, ida, ptvirga)) +> A.rewrap decla,
- (((Some ((idb,None),[iidb]),typb,stob,local),iivirg),
- iiptvirgb,iistob)
- )))))
-
- | A.Init (stoa, typa, ida, eqa, inia, ptvirga),
- ((Some((idb,Some inib),[iidb;iieqb]),typb,stob,local),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) ->
- 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,
- (((Some((idb,Some inib),[iidb;iieqb]),typb,stob,local),iivirg),
- iiptvirgb,iistob)
- )))))))
-
- (* do iso-by-absence here ? allow typedecl and var ? *)
- | A.TyDecl (typa, ptvirga), ((None, typb, stob, local), iivirg) ->
- if stob = (B.NoSto, false)
- then
- tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
- fullType typa typb >>= (fun typa typb ->
- return (
- (A.TyDecl (typa, ptvirga)) +> A.rewrap decla,
- (((None, typb, stob, local), iivirg), iiptvirgb, iistob)
- )))
- else fail
-
-
- | A.Typedef (stoa, typa, ida, ptvirga),
- ((Some ((idb, None),[iidb]),typb,(B.StoTypedef,inline),local),iivirg) ->
-
- tokenf ptvirga iiptvirgb >>= (fun ptvirga iiptvirgb ->
- fullType typa typb >>= (fun typa typb ->
- (match iistob with
- | [iitypedef] ->
- tokenf stoa iitypedef >>= (fun stoa iitypedef ->
- return (stoa, [iitypedef])
- )
- | _ -> failwith "wierd, have both typedef and inline or nothing";
- ) >>= (fun stoa iistob ->
- (match A.unwrap ida with
- | A.MetaType(_,_,_) ->
-
- let fake_typeb =
- Ast_c.nQ, ((B.TypeName (idb, Ast_c.noTypedefDef())), [iidb])
- in
- fullTypebis ida fake_typeb >>= (fun ida fake_typeb ->
- match fake_typeb with
- | _nQ, ((B.TypeName (idb,_typ)), [iidb]) ->
- return (ida, (idb, iidb))
- | _ -> 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
- | _ -> raise Impossible
-
- ) >>= (fun ida (idb, iidb) ->
- return (
- (A.Typedef (stoa, typa, ida, ptvirga)) +> A.rewrap decla,
- (((Some ((idb, None),[iidb]), typb, (B.StoTypedef,inline),local),
- iivirg),
- iiptvirgb, iistob)
- )
- ))))
-
-
- | _, ((None, typb, sto, _local), _) ->
- (* old: failwith "no variable in this declaration, wierd" *)
- fail
-
-
-
- | 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 _, _ ->
- failwith "not handling Opt/Unique Decl"
-
-
- | _, _ -> fail
-
-
-
-(* ------------------------------------------------------------------------- *)
-
-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.InitExpr expa, ib) ->
- (match A.unwrap expa, ib with
- | 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.rewrap ia,
- ib
- ))
-
- | A.Edots (_, Some expr), _ -> failwith "not handling when on Edots"
-
- | _, (B.InitExpr expb, ii) ->
- assert (null ii);
- 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 ->
- tokenf ia1 ib1 >>= (fun ia1 ib1 ->
- tokenf ia2 ib2 >>= (fun ia2 ib2 ->
- initialisers ias (ibs, iicommaopt) >>= (fun ias (ibs,iicommaopt) ->
- return (
- (A.InitList (ia1, ias, ia2, [])) +> A.rewrap ia,
- (B.InitList ibs, ib1::ib2::iicommaopt)
- ))))
-
- | _ -> raise Impossible
- )
-
- | (A.InitList (i1, ias, i2, whencode),(B.InitList ibs, _ii)) ->
- failwith "TODO: not handling whencode in initialisers"
-
-
- | (A.InitGccDotName (ia1, ida, ia2, inia),
- (B.InitDesignators ([B.DesignatorField idb,ii1], inib), ii2))->
-
- let (iidot, iidb) = tuple_of_list2 ii1 in
- let iieq = tuple_of_list1 ii2 in
-
- tokenf ia1 iidot >>= (fun ia1 iidot ->
- tokenf ia2 iieq >>= (fun ia2 iieq ->
- ident DontKnow ida (idb, iidb) >>= (fun ida (idb, iidb) ->
- initialiser inia inib >>= (fun inia inib ->
- return (
- (A.InitGccDotName (ia1, ida, ia2, inia)) +> A.rewrap ia,
- (B.InitDesignators
- ([B.DesignatorField idb, [iidot;iidb]], inib), [iieq])
- )))))
-
-
- | (A.InitGccIndex (ia1,ea,ia2,ia3,inia),
- (B.InitDesignators ([B.DesignatorIndex eb, ii1], inib), ii2)) ->
-
- let (ib1, ib2) = tuple_of_list2 ii1 in
- let ib3 = tuple_of_list1 ii2 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 ->
- initialiser inia inib >>= (fun inia inib ->
- return (
- (A.InitGccIndex (ia1,ea,ia2,ia3,inia)) +> A.rewrap ia,
- (B.InitDesignators
- ([B.DesignatorIndex eb, [ib1;ib2]], inib), [ib3])
- ))))))
-
-
- | (A.InitGccRange (ia1,e1a,ia2,e2a,ia3,ia4,inia),
- (B.InitDesignators ([B.DesignatorRange (e1b, e2b), ii1], inib), ii2)) ->
-
- let (ib1, ib2, ib3) = tuple_of_list3 ii1 in
- let (ib4) = tuple_of_list1 ii2 in
- 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 e1a e1b >>= (fun e1a e1b ->
- expression e2a e2b >>= (fun e2a e2b ->
- initialiser inia inib >>= (fun inia inib ->
- return (
- (A.InitGccRange (ia1,e1a,ia2,e2a,ia3,ia4,inia)) +> A.rewrap ia,
- (B.InitDesignators
- ([B.DesignatorRange (e1b, e2b),[ib1;ib2;ib3]], inib), [ib4])
- ))))))))
-
-
-
-
- | (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])
- ))))
- | _ -> fail
- )
-
-
-
- | A.IComma(comma), _ ->
- raise Impossible
-
- | A.UniqueIni _,_ | A.OptIni _,_ ->
- failwith "not handling Opt/Unique on initialisers"
-
- | _, _ -> fail
-
-
-
-
-
-and initialisers = fun ias (ibs, iicomma) ->
- let ias_unsplit = unsplit_icomma ias in
- let ibs_split = resplit_initialiser ibs iicomma in
-
- let f =
- if need_unordered_initialisers ibs
- then initialisers_unordered2
- else initialisers_ordered2
- in
- 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 ->
- match ias, ibs with
- | [], [] -> return ([], [])
- | (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 ->
- return (
- (x, (A.IComma commax) +> A.rewrap xcomma)::xs,
- (y, commay)::ys
- )
- )))
- | _ -> raise Impossible (* unsplit_iicomma wrong *)
- )
- | _ -> fail
-
-
-
-and initialisers_unordered2 = fun ias ibs ->
-
- match ias, ibs with
- | [], ys -> return ([], ys)
- | (x,xcomma)::xs, ys ->
-
- let permut = Common.uncons_permut_lazy ys in
- 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 ->
- return (
- (x, (A.IComma commax) +> A.rewrap xcomma),
- (y, commay))
- )
- )
- | _ -> raise Impossible (* unsplit_iicomma wrong *)
- )
- >>= (fun x e ->
- let rest = Lazy.force rest in
- 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 B.wrap list) matcher) =
- fun eas ebs ->
- match eas, ebs with
- | [], [] -> return ([], [])
- | [], eb::ebs -> fail
- | ea::eas, ebs ->
- X.all_bound (A.get_inherited ea) >&&>
- (match A.unwrap ea, ebs with
- | 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) ->
- acc >||> (
-
- (if startxs = []
- then
- if mcode_contain_plus (mcodekind mcode)
- then fail
- (* failwith "I have no token that I could accroche myself on" *)
- else return (dots2metavar mcode, [])
- else
-
- X.distrf_struct_fields (dots2metavar mcode) startxs
- ) >>= (fun mcode startxs ->
- let mcode = metavar2dots mcode in
- 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 ->
- return (ea::eas, eb::ebs)
- ))
-
- | _unwrapx, [] -> fail
- )
-
-and (struct_field: (A.declaration, B.field B.wrap) matcher) = fun fa fb ->
- let (xfield, ii) = fb in
- let iiptvirgb = tuple_of_list1 ii in
-
- match xfield with
- | B.FieldDeclList onefield_multivars ->
-
- (match onefield_multivars with
- | [] -> raise Impossible
- | [onevar,iivirg] ->
- assert (null iivirg);
- (match onevar with
- | B.BitField (sopt, typb, expr), ii ->
- pr2_once "warning: bitfield not handled by ast_cocci";
- fail
- | B.Simple (None, typb), ii ->
- 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
-
- (* build a declaration from a struct field *)
- let allminus = false in
- let iisto = [] in
- let stob = B.NoSto, false in
- let fake_var =
- ((Some ((idb, None),[iidb]), typb, stob, Ast_c.NotLocalDecl),
- iivirg)
- in
- onedecl allminus fa (fake_var,iiptvirgb,iisto) >>=
- (fun fa (var,iiptvirgb,iisto) ->
-
- match fake_var with
- | ((Some ((idb, None),[iidb]), typb, stob, local), iivirg) ->
- let onevar = B.Simple (Some idb, typb), [iidb] in
-
- return (
- (fa),
- (B.FieldDeclList [onevar, iivirg], [iiptvirgb])
- )
- | _ -> raise Impossible
- )
- )
-
- | x::y::xs ->
- pr2_once "PB: More that one variable in decl. Have to split";
- fail
- )
- | B.EmptyField -> fail
-
-
-
-(* ------------------------------------------------------------------------- *)
-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
- then
- pr2_once
- ("warning: the type is both const & volatile but cocci " ^
- "does not handle that");
-
- (* Drop out the const/volatile part that has been matched.
- * This is because a SP can contain const T v; in which case
- * 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 ->
- return (
- (A.Type(None, ty1)) +> A.rewrap typa,
- fullty2
- ))
- in
- (match optional_qualifier, qu.B.const || qu.B.volatile with
- | false, false -> do_stuff ()
- | false, true -> fail
- | true, false -> do_stuff ()
- | 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 ?
- *)
- (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) ->
- return (
- (A.Type(Some x, ty1)) +> A.rewrap typa,
- ((qu, [i1]), ty2)
- )))
-
- | _ -> fail
- )
- )
-
- | 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,
- * 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) >&&>
- match A.unwrap ta, tb with
-
- (* cas general *)
- | 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 ->
- return (
- A.MetaType(ida,keep, inherited) +> A.rewrap ta,
- typb
- ))
- )
- | unwrap, (qub, typb) ->
- typeC ta typb >>= (fun ta typb ->
- return (ta, (qub, typb))
- )
-
-
-and (typeC: (A.typeC, Ast_c.typeC) matcher) =
- fun ta tb ->
- match A.unwrap ta, tb with
- | A.BaseType (basea, signaopt), (B.BaseType baseb, ii) ->
- (* 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
- * 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 term basea, baseb with
- | A.VoidType, B.Void
- | A.FloatType, B.FloatType (B.CFloat)
- | A.DoubleType, B.FloatType (B.CDouble) ->
- assert (signaopt = None);
- let (ibaseb) = tuple_of_list1 ii in
- tokenf basea ibaseb >>= (fun basea ibaseb ->
- return (
- (A.BaseType (basea, signaopt)) +> A.rewrap ta,
- (B.BaseType baseb, [ibaseb])
- ))
-
- | A.CharType, B.IntType B.CChar when signaopt = None ->
- let ibaseb = tuple_of_list1 ii in
- tokenf basea ibaseb >>= (fun basea ibaseb ->
- return (
- (A.BaseType (basea, signaopt)) +> A.rewrap ta,
- (B.BaseType (B.IntType B.CChar), [ibaseb])
- ))
-
- | A.CharType,B.IntType (B.Si (_sign, B.CChar2)) when signaopt <> None ->
- let ibaseb = tuple_of_list1 iibaseb in
- sign signaopt signbopt >>= (fun signaopt iisignbopt ->
- tokenf basea ibaseb >>= (fun basea ibaseb ->
- return (
- (A.BaseType (basea, 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.LongType, B.IntType (B.Si (_, B.CLong)) ->
- (match iibaseb with
- | [] ->
- (* iso-by-presence ? *)
- (* when unsigned int in SP, allow have just unsigned in C ? *)
- if mcode_contain_plus (mcodekind basea)
- then fail
- else
-
- sign signaopt signbopt >>= (fun signaopt iisignbopt ->
- return (
- (A.BaseType (basea, signaopt)) +> A.rewrap ta,
- (B.BaseType (baseb), iisignbopt ++ [])
- ))
-
-
- | [x;y] ->
- pr2_once
- "warning: long int or short int not handled by ast_cocci";
- fail
-
- | [ibaseb] ->
- sign signaopt signbopt >>= (fun signaopt iisignbopt ->
- tokenf basea ibaseb >>= (fun basea ibaseb ->
- return (
- (A.BaseType (basea, signaopt)) +> A.rewrap ta,
- (B.BaseType (baseb), iisignbopt ++ [ibaseb])
- )))
- | _ -> raise Impossible
-
- )
-
-
- | _, B.IntType (B.Si (_, B.CLongLong))
- | _, B.FloatType B.CLongDouble
- ->
- pr2_once
- "warning: long long or long double not handled by ast_cocci";
- fail
-
-
- | _, _ -> fail
-
-
- )
-
- | A.ImplicitInt (signa), (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 ->
- match signaopt with
- | None -> raise Impossible
- | Some signa ->
- return (
- (A.ImplicitInt (signa)) +> A.rewrap ta,
- (B.BaseType baseb, iisignbopt)
- )
- )
- | _ -> fail
- )
-
-
-
- (* 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 ->
- 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) ->
-
- let (lpb, rpb) = tuple_of_list2 ii in
- 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 ->
- parameters (seqstyle paramsa) (A.undots paramsa) 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),
- (B.ParenType t1, ii) ->
- let (lp1b, rp1b) = tuple_of_list2 ii in
- let (qu1b, t1b) = t1 in
- (match t1b with
- | 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 ->
- let (lp2b, rp2b) = tuple_of_list2 ii in
-
- if isvaargs
- then
- pr2_once
- ("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 ->
- parameters (seqstyle paramsa) (A.undots paramsa) paramsb >>=
- (fun paramsaundots paramsb ->
- let paramsa = redots paramsa paramsaundots in
-
- let t2 =
- (qu2b,
- (B.FunctionType (tyb, (paramsb, (isvaargs, iidotsb))),
- [lp2b;rp2b]))
- in
- let t1 =
- (qu1b,
- (B.Pointer t2, [starb]))
- in
-
- return (
- (A.FunctionPointer(tya,lp1a,stara,rp1a,lp2a,paramsa,rp2a))
- +> A.rewrap ta,
- (B.ParenType t1, [lp1b;rp1b])
- )
- )))))))
-
-
-
- | _ -> fail
- )
- | _ -> fail
- )
-
-
-
- (* todo: handle the iso on optionnal size specifification ? *)
- | 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 ->
- return (
- (A.Array (typa, ia1, eaopt, ia2)) +> A.rewrap ta,
- (B.Array (ebopt, typb), [ib1;ib2])
- )))))
-
-
- (* todo: could also match a Struct that has provided a name *)
- (* This is for the case where the SmPL code contains "struct x", without
- 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) ->
- (* 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
- then
- 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) ->
-
- let (ii_sub_sb, lbb, rbb) =
- match ii with
- [iisub; lbb; rbb] -> (Common.Left iisub,lbb,rbb)
- | [iisub; iisb; lbb; rbb] -> (Common.Right (iisub,iisb),lbb,rbb)
- | _ -> failwith "list of length 3 or 4 expected" in
-
- let process_type =
- match (sbopt,ii_sub_sb) with
- (None,Common.Left iisub) ->
- (* the following doesn't reconstruct the complete SP code, just
- the part that matched *)
- let rec loop s =
- match A.unwrap s with
- A.Type(None,ty) ->
- (match A.unwrap ty with
- A.StructUnionName(sua, None) ->
- tokenf sua iisub >>= (fun sua iisub ->
- let ty =
- A.Type(None,
- A.StructUnionName(sua, None) +> A.rewrap ty)
- +> A.rewrap s in
- return (ty,[iisub]))
- | _ -> fail)
- | A.DisjType(disjs) ->
- disjs +>
- 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 ->
- match fake_su with
- | _nQ, (B.StructUnionName (sub, sb), [iisub;iisb]) ->
- return (ty, [iisub; iisb])
- | _ -> raise Impossible)
- | _ -> fail in
-
- process_type
- >>= (fun ty ii_sub_sb ->
-
- 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
-
- return (
- (A.StructUnionDef(ty, lba, declsa, rba)) +> A.rewrap ta,
- (B.StructUnion (sub, sbopt, declsb),ii_sub_sb@[lbb;rbb])
- )))))
-
-
- (* 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.
- *)
- | 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
-
- | _, (B.TypeOfExpr e, ii) -> fail
- | _, (B.TypeOfType e, ii) -> fail
-
- | _, _ -> fail
-
-(* 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 =
- match signa, signb with
- | None, None -> return (None, [])
- | Some signa, Some (signb, ib) ->
- if equal_sign (term signa) signb
- 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 ->
- return (minus::xs, ii::ys)
- ))) (return ([],[]))
- >>= (fun _xsminys ys ->
- return ((), List.rev ys)
- )
-
-and storage_optional_allminus allminus stoa (stob, iistob) =
- (* "iso-by-absence" for storage, and return type. *)
- 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 ->
- return (None, (stob, iistob))
- )
- else return (None, (stob, iistob))
- in
-
- (match optional_storage, stobis with
- | false, B.NoSto -> do_minus ()
- | false, _ -> fail
- | true, B.NoSto -> do_minus ()
- | true, _ ->
- if !Flag.show_misc
- then pr2_once "USING optional_storage builtin isomorphism";
- do_minus()
- )
-
- | 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
- else fail
- )
-
-
-
-
-
-and fullType_optional_allminus allminus tya retb =
- match tya with
- | None ->
- if allminus
- then
- X.distrf_type minusizer retb >>= (fun _x retb ->
- return (None, retb)
- )
-
- else return (None, retb)
- | Some tya ->
- fullType tya retb >>= (fun tya retb ->
- return (Some tya, retb)
- )
-
-
-
-(*---------------------------------------------------------------------------*)
-and compatible_type a (b,_local) =
- let ok = return ((),()) in
-
- let rec loop = function
- | Type_cocci.BaseType (a, signa), (qua, (B.BaseType b,ii)) ->
- (match a, b with
- | Type_cocci.VoidType, B.Void ->
- assert (signa = None);
- ok
- | 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)) ->
- compatible_sign signa signb
- | Type_cocci.IntType, B.IntType (B.Si (signb, B.CInt)) ->
- compatible_sign signa signb
- | Type_cocci.LongType, B.IntType (B.Si (signb, B.CLong)) ->
- compatible_sign signa signb
- | _, B.IntType (B.Si (signb, B.CLongLong)) ->
- pr2_once "no longlong in cocci";
- fail
- | Type_cocci.FloatType, B.FloatType B.CFloat ->
- assert (signa = None);
- ok
- | Type_cocci.DoubleType, B.FloatType B.CDouble ->
- assert (signa = None);
- ok
- | _, B.FloatType B.CLongDouble ->
- pr2_once "no longdouble in cocci";
- fail
- | Type_cocci.BoolType, _ -> failwith "no booltype in C"
- | _ -> fail
-
- )
- | Type_cocci.Pointer a, (qub, (B.Pointer b, ii)) ->
- loop (a,b)
- | Type_cocci.FunctionPointer a, _ ->
- failwith
- "TODO: function pointer type doesn't store enough information to determine compatability"
- | Type_cocci.Array a, (qub, (B.Array (eopt, b),ii)) ->
- (* no size info for cocci *)
- loop (a,b)
- | Type_cocci.StructUnionName (sua, _, sa),
- (qub, (B.StructUnionName (sub, sb),ii)) ->
- if equal_structUnion_type_cocci sua sub && sa = sb
- then ok
- else fail
-
- | Type_cocci.TypeName sa, (qub, (B.TypeName (sb,_typb), ii)) ->
- if sa = sb
- then ok
- else fail
-
- | 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
- | 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 ->
- 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)
- (fun () -> ok
- )
-
- (* subtil: must be after the MetaType case *)
- | a, (qub, (B.TypeName (sb,Some b), ii)) ->
- (* kind of typedef iso *)
- loop (a,b)
-
-
-
-
-
- (* for metavariables of type expression *^* *)
- | Type_cocci.Unknown , _ -> ok
-
- | _ -> fail in
- loop (a,b)
-
-and compatible_sign signa signb =
- let ok = return ((),()) in
- match signa, signb with
- | None, B.Signed
- | Some Type_cocci.Signed, B.Signed
- | Some Type_cocci.Unsigned, B.UnSigned
- -> ok
- | _ -> fail
-
-
-and equal_structUnion_type_cocci a b =
- match a, b with
- | Type_cocci.Struct, B.Struct -> true
- | Type_cocci.Union, B.Union -> true
- | _, _ -> false
-
-
-
-(*---------------------------------------------------------------------------*)
-and inc_file (a, before_after) (b, h_rel_pos) =
-
- let rec aux_inc (ass, bss) passed =
- match ass, bss with
- | [], [] -> true
- | [A.IncDots], _ ->
- let passed = List.rev passed in
-
- (match before_after, !h_rel_pos with
- | IncludeNothing, _ -> true
- | IncludeMcodeBefore, Some x ->
- List.mem passed (x.Ast_c.first_of)
-
- | 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
- )
-
- | (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 ->
- aux_inc (ass, 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 ->
- match seqstyle with
- | Unordered -> failwith "not handling ooo"
- | 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 ->
- match eas, ebs with
- | [], [] -> return ([], [])
- | [], eb::ebs -> fail
- | ea::eas, ebs ->
- X.all_bound (A.get_inherited ea) >&&>
- (match A.unwrap ea, ebs with
- | 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) ->
- acc >||> (
-
- (if startxs = []
- then
- if mcode_contain_plus (mcodekind mcode)
- then fail
- (* failwith "I have no token that I could accroche myself on" *)
- else return (dots2metavar mcode, [])
- else
- (match Common.last startxs with
- | Right _ -> fail
- | Left _ ->
- X.distrf_define_params (dots2metavar mcode) startxs
- )
- ) >>= (fun mcode startxs ->
- let mcode = metavar2dots mcode in
- define_paramsbis eas endxs >>= (fun eas endxs ->
- return (
- (A.DPdots (mcode) +> A.rewrap ea) ::eas,
- startxs ++ endxs
- )))
- )
- ) fail
-
- | 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 ->
- return (
- (A.DPComma ia1 +> A.rewrap ea)::eas,
- (Right [ib1])::ebs
- )
- ))
-
- | A.DPComma ia1, ebs ->
- if mcode_contain_plus (mcodekind ia1)
- then fail
- else
- (define_paramsbis eas ebs) (* try optional comma trick *)
-
- | (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 ->
- let ib1 = tuple_of_list1 ii in
- 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
- )
-
-
-
-(*****************************************************************************)
-(* Entry points *)
-(*****************************************************************************)
-
-(* 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 =
- x >>= (fun a b -> return (A.rewrap re a, F.rewrap node b))
- in
- X.all_bound (A.get_inherited re) >&&>
-
- rewrap (
- match A.unwrap re, F.unwrap node with
-
- (* note: the order of the clauses is important. *)
-
- | _, F.Enter | _, F.Exit | _, F.ErrorExit -> fail2()
-
- (* 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.
- * Can match TrueNode/FalseNode/... so must be placed before those cases.
- *)
-
- | 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.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
- (* 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))
- else return unwrap_node
- *)
- raise Todo
-
- | F.EndStatement (Some i1) ->
- tokenf mcode i1 >>= (fun mcode i1 ->
- return (
- A.MetaRuleElem (mcode,keep, inherited),
- F.EndStatement (Some i1)
- ))
-
- | 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 ->
- return (
- A.MetaRuleElem(mcode,keep, inherited),
- F.unwrap node
- ))
- )
-
-
- (* rene cant have found that a state containing a fake/exit/... should be
- * transformed
- * TODO: and F.Fake ?
- *)
- | _, F.EndStatement _ | _, F.CaseNode _
- | _, F.TrueNode | _, F.FalseNode | _, F.AfterNode | _, F.FallThroughNode
- | _, F.InLoopNode
- -> fail2()
-
- (* really ? diff between pattern.ml and transformation.ml *)
- | _, F.Fake -> fail2()
-
-
- (* 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.
- *)
- | A.MetaStmt (ida,keep,metainfoMaybeTodo,inherited), F.Decl(_) -> fail
-
- | 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 ->
- 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 () ->
- (* no need tag ida, we can't be called in transform-mode *)
- return (
- A.MetaStmt (ida, keep, metainfoMaybeTodo, inherited),
- unwrap_node
- )
- )
- | None -> fail
- )
-
- (* not me?: *)
- | A.MetaStmtList _, _ ->
- failwith "not handling MetaStmtList"
-
- | A.TopExp ea, F.DefineExpr 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 ->
- 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
- * of the lack of the counter part of a C construct in SmPL (for instance
- * there is not yet a CaseRange in SmPL). Even if SmPL don't handle
- * yet certain constructs, those constructs may contain expression
- * that we still want and can transform.
- *)
-
- | A.Exp exp, nodeb ->
-
- (* kind of iso, initialisation vs affectation *)
- let node =
- match A.unwrap exp, nodeb with
- | 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,
- * so that can then get in a MetaStmtVar the fullstatement to later
- * 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
- * visiteur que sur le partialstatement.
- *)
- let expfn =
- match Ast_cocci.get_pos re with
- | None -> expression
- | 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 () ->
- expression ea eb
- )
- )
- in
- 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 ->
- return (
- A.Ty ty,
- F.unwrap node
- )
- )
-
- | A.TopInit init, nodeb ->
- X.cocciInit initialiser init node >>= (fun init node ->
- return (
- A.TopInit init,
- F.unwrap node
- )
- )
-
-
- | A.FunHeader (mckstart, allminus, fninfoa, ida, oparen, paramsa, cparen),
- F.FunHeader ((idb, (retb, (paramsb, (isvaargs, iidotsb))), stob), ii) ->
-
- (* fninfoa records the order in which the SP specified the various
- information, but this isn't taken into account in the matching.
- Could this be a problem for transformation? *)
- let stoa =
- match
- List.filter (function A.FStorage(s) -> true | _ -> false) fninfoa
- with [A.FStorage(s)] -> Some s | _ -> None in
- let tya =
- match List.filter (function A.FType(s) -> true | _ -> false) fninfoa
- with [A.FType(t)] -> Some t | _ -> None in
-
- (match List.filter (function A.FInline(i) -> true | _ -> false) fninfoa
- with [A.FInline(i)] -> failwith "not checking inline" | _ -> ());
-
- (match List.filter (function A.FAttr(a) -> true | _ -> false) fninfoa
- with [A.FAttr(a)] -> failwith "not checking attributes" | _ -> ());
-
- (match ii with
- | iidb::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) ->
- X.tokenf_mck mckstart iifakestart >>= (fun mckstart iifakestart ->
- tokenf oparen ioparenb >>= (fun oparen ioparenb ->
- tokenf cparen icparenb >>= (fun cparen icparenb ->
- parameters (seqstyle paramsa)
- (A.undots paramsa) paramsb >>=
- (fun paramsaundots paramsb ->
- let paramsa = redots paramsa paramsaundots in
- storage_optional_allminus allminus
- stoa (stob, iistob) >>= (fun stoa (stob, iistob) ->
- (
- 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 ->
-
- let fninfoa =
- (match stoa with Some st -> [A.FStorage st] | None -> []) ++
- (match tya with Some t -> [A.FType t] | None -> [])
-
- in
-
- return (
- A.FunHeader(mckstart,allminus,fninfoa,ida,oparen,
- paramsa,cparen),
- F.FunHeader ((idb, (retb, (paramsb, (isvaargs, iidotsb))),
- stob),
- iidb::ioparenb::icparenb::iifakestart::iistob)
- )
- ))))))))
- | _ -> raise Impossible
- )
-
-
-
-
-
-
- | 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 ->
- return (
- A.SeqStart mcode,
- F.SeqStart (st, level, 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 ->
- return (
- A.ExprStatement (ea, ia1),
- F.ExprStatement (st, (Some eb, [ib1]))
- )
- ))
-
-
- | 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 ->
- 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 ->
- return (A.Else ia, F.Else ib)
- )
-
- | 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 ->
- return (
- 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 ->
- return (
- A.DoHeader ia,
- F.DoHeader (st, ib)
- ))
- | 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 ->
- return (
- 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 ->
- let eas = redots eas easundots in
- return (
- A.IteratorHeader (ia1, ia2, eas, ia3),
- F.MacroIterHeader (st, ((s,ebs), [ib1;ib2;ib3]))
- )))))
-
-
-
- | 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 ->
- tokenf ia4 ib4 >>= (fun ia4 ib4 ->
- tokenf ia5 ib5 >>= (fun ia5 ib5 ->
- option expression ea1opt eb1opt >>= (fun ea1opt eb1opt ->
- option expression ea2opt eb2opt >>= (fun ea2opt eb2opt ->
- option expression ea3opt eb3opt >>= (fun ea3opt eb3opt ->
- return (
- A.ForHeader (ia1, ia2, ea1opt, ia3, ea2opt, ia4, ea3opt, ia5),
- F.ForHeader (st, (((eb1opt,[ib3]), (eb2opt,[ib4]), (eb3opt,[])),
- [ib1;ib2;ib5]))
-
- )))))))))
-
-
- | 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 ->
- return (
- A.SwitchHeader(ia1,ia2,ea,ia3),
- F.SwitchHeader (st, (eb,[ib1;ib2;ib3]))
- )))))
-
- | 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 ->
- return (
- A.Break (ia1, ia2),
- F.Break (st, ((),[ib1;ib2]))
- )))
-
- | 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 ->
- return (
- A.Continue (ia1, ia2),
- F.Continue (st, ((),[ib1;ib2]))
- )))
-
- | 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 ->
- return (
- A.Return (ia1, ia2),
- F.Return (st, ((),[ib1;ib2]))
- )))
-
- | 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 ->
- return (
- A.ReturnExpr (ia1, ea, ia2),
- F.ReturnExpr (st, (eb, [ib1;ib2]))
- ))))
-
-
-
- | A.Include(incla,filea), F.Include ((fileb, ii), (h_rel_pos, inifdef)) ->
-
- let include_requirment =
- match mcodekind incla, mcodekind filea with
- | A.CONTEXT (_, A.BEFORE _), _ ->
- IncludeMcodeBefore
- | _, A.CONTEXT (_, A.AFTER _) ->
- IncludeMcodeAfter
- | _ ->
- IncludeNothing
- 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 ->
- return (
- A.Include(incla, filea),
- F.Include ((fileb, [inclb;iifileb]), (h_rel_pos, inifdef))
- )))
- else fail
-
-
-
- | 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 ->
- (match A.unwrap params, defkind with
- | A.NoParams, B.DefineVar ->
- return (
- A.NoParams +> A.rewrap params,
- B.DefineVar
- )
- | 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 ->
-
- 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,
- B.DefineFunc (ebs,[lpb;rpb])
- )
- )))
- | _ -> fail
- ) >>= (fun params defkind ->
- return (
- A.DefineHeader (definea, ida, params),
- F.DefineHeader ((idb,[defineb;iidb;ieol]),defkind)
- ))
- ))
-
-
- | 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 ->
- return (
- A.Default(def,colon),
- F.Default (st, ((),[ib1;ib2]))
- )))
-
-
-
- | 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 ->
- return (
- A.Case(case,ea,colon),
- F.Case (st, (eb,[ib1;ib2]))
- ))))
-
- (* only occurs in the predicates generated by asttomember *)
- | 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))
-
- | _, 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.Goto(goto,id,sem), F.Goto (st,(s,ii)) ->
- let (ib1,ib2,ib3) = tuple_of_list3 ii in
- tokenf goto ib1 >>= (fun goto ib1 ->
- ident DontKnow id (s, ib2) >>= (fun id (s, ib2) ->
- tokenf sem ib3 >>= (fun sem ib3 ->
- return(
- A.Goto(goto,id,sem),
- F.Goto (st,(s,[ib1;ib2;ib3]))
- ))))
-
- (* have not a counter part in coccinelle, for the moment *)
- (* todo?: print a warning at least ? *)
- | _, F.CaseRange _
- | _, F.Asm _
- | _, F.Ifdef _
- | _, F.MacroTop _
- -> fail2()
-
-
- | _, _ -> fail
- )
-end
-
HCoop / bpt / coccinelle.git / blobdiff