X-Git-Url: http://git.hcoop.net/bpt/coccinelle.git/blobdiff_plain/9bc82bae75129fec4d981ebf245f2f7d7ca73a41..d6ce1786f27a05efa53cabeca92fc8e744a4b239:/parsing_cocci/ast0_cocci.ml diff --git a/parsing_cocci/ast0_cocci.ml b/parsing_cocci/ast0_cocci.ml index da681d0..3af2123 100644 --- a/parsing_cocci/ast0_cocci.ml +++ b/parsing_cocci/ast0_cocci.ml @@ -1,5 +1,7 @@ (* - * Copyright 2010, INRIA, University of Copenhagen + * Copyright 2012, INRIA + * Julia Lawall, Gilles Muller + * Copyright 2010-2011, INRIA, University of Copenhagen * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix @@ -22,8 +24,11 @@ *) +# 0 "./ast0_cocci.ml" (* - * Copyright 2010, INRIA, University of Copenhagen + * Copyright 2012, INRIA + * Julia Lawall, Gilles Muller + * Copyright 2010-2011, INRIA, University of Copenhagen * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix @@ -46,6 +51,7 @@ *) +# 0 "./ast0_cocci.ml" module Ast = Ast_cocci module TC = Type_cocci @@ -62,10 +68,9 @@ let default_token_info = (* MIXED is like CONTEXT, since sometimes MIXED things have to revert to CONTEXT - see insert_plus.ml *) -type count = ONE (* + *) | MANY (* ++ *) type mcodekind = - MINUS of (Ast.anything list list * token_info) ref + MINUS of (Ast.anything Ast.replacement * token_info) ref | PLUS of Ast.count | CONTEXT of (Ast.anything Ast.befaft * token_info * token_info) ref | MIXED of (Ast.anything Ast.befaft * token_info * token_info) ref @@ -79,13 +84,14 @@ type info = { pos_info : position_info; mcode_start : mcodekind list; mcode_end : mcodekind list; (* the following are only for + code *) strings_before : (Ast.added_string * position_info) list; - strings_after : (Ast.added_string * position_info) list } + strings_after : (Ast.added_string * position_info) list; + isSymbolIdent : bool; (* is the token a symbol identifier or not *) } (* adjacency index is incremented when we skip over dots or nest delimiters it is used in deciding how much to remove, when two adjacent code tokens are removed. *) type 'a mcode = - 'a * arity * info * mcodekind * meta_pos ref (* pos, - only *) * + 'a * arity * info * mcodekind * anything list ref (* pos, - only *) * int (* adjacency_index *) (* int ref is an index *) and 'a wrap = @@ -128,9 +134,12 @@ and 'a dots = 'a base_dots wrap and base_ident = Id of string mcode - | MetaId of Ast.meta_name mcode * Ast.idconstraint * pure + | MetaId of Ast.meta_name mcode * Ast.idconstraint * Ast.seed * pure | MetaFunc of Ast.meta_name mcode * Ast.idconstraint * pure | MetaLocalFunc of Ast.meta_name mcode * Ast.idconstraint * pure + | AsIdent of ident * ident (* as ident, always metavar *) + | DisjId of string mcode * ident list * + string mcode list (* the |s *) * string mcode | OptIdent of ident | UniqueIdent of ident @@ -146,6 +155,7 @@ and base_expression = expression dots * string mcode (* ) *) | Assignment of expression * Ast.assignOp mcode * expression * bool (* true if it can match an initialization *) + | Sequence of expression * string mcode (* , *) * expression | CondExpr of expression * string mcode (* ? *) * expression option * string mcode (* : *) * expression | Postfix of expression * Ast.fixOp mcode @@ -165,11 +175,14 @@ and base_expression = | SizeOfType of string mcode (* sizeof *) * string mcode (* ( *) * typeC * string mcode (* ) *) | TypeExp of typeC (* type name used as an expression, only in args *) + | Constructor of string mcode (* ( *) * typeC * string mcode (* ) *) * + initialiser | MetaErr of Ast.meta_name mcode * constraints * pure | MetaExpr of Ast.meta_name mcode * constraints * TC.typeC list option * Ast.form * pure | MetaExprList of Ast.meta_name mcode (* only in arg lists *) * listlen * pure + | AsExpr of expression * expression (* as expr, always metavar *) | EComma of string mcode (* only in arg lists *) | DisjExpr of string mcode * expression list * string mcode list (* the |s *) * string mcode @@ -218,6 +231,7 @@ and base_typeC = string mcode (* { *) * declaration dots * string mcode (* } *) | TypeName of string mcode | MetaType of Ast.meta_name mcode * pure + | AsType of typeC * typeC (* as type, always metavar *) | DisjType of string mcode * typeC list * (* only after iso *) string mcode list (* the |s *) * string mcode | OptType of typeC @@ -236,12 +250,17 @@ and base_declaration = they don't match the same thin at all. Consider whether there should be a separate type for fields, as in the C AST *) | MetaField of Ast.meta_name mcode * pure (* structure fields *) + | MetaFieldList of Ast.meta_name mcode * listlen * pure (* structure fields *) + | AsDecl of declaration * declaration | Init of Ast.storage mcode option * typeC * ident * string mcode (*=*) * initialiser * string mcode (*;*) | UnInit of Ast.storage mcode option * typeC * ident * string mcode (* ; *) | TyDecl of typeC * string mcode (* ; *) | MacroDecl of ident (* name *) * string mcode (* ( *) * expression dots * string mcode (* ) *) * string mcode (* ; *) + | MacroDeclInit of ident (* name *) * string mcode (* ( *) * + expression dots * string mcode (* ) *) * string mcode (*=*) * + initialiser * string mcode (* ; *) | Typedef of string mcode (* typedef *) * typeC * typeC * string mcode (*;*) | DisjDecl of string mcode * declaration list * string mcode list (* the |s *) * string mcode @@ -257,6 +276,8 @@ and declaration = base_declaration wrap and base_initialiser = MetaInit of Ast.meta_name mcode * pure + | MetaInitList of Ast.meta_name mcode * listlen * pure + | AsInit of initialiser * initialiser (* as init, always metavar *) | InitExpr of expression | InitList of string mcode (*{*) * initialiser_list * string mcode (*}*) * (* true if ordered, as for array, false if unordered, as for struct *) @@ -326,7 +347,7 @@ and base_statement = Decl of (info * mcodekind) (* before the decl *) * declaration | Seq of string mcode (* { *) * statement dots * string mcode (* } *) - | ExprStatement of expression * string mcode (*;*) + | ExprStatement of expression option * string mcode (*;*) | IfThen of string mcode (* if *) * string mcode (* ( *) * expression * string mcode (* ) *) * statement * (info * mcodekind) (* after info *) @@ -362,6 +383,7 @@ and base_statement = string mcode (* ; *) | MetaStmt of Ast.meta_name mcode * pure | MetaStmtList of Ast.meta_name mcode(*only in statement lists*) * pure + | AsStmt of statement * statement (* as statement, always metavar *) | Exp of expression (* only in dotted statement lists *) | TopExp of expression (* for macros body *) | Ty of typeC (* only at top level *) @@ -382,6 +404,7 @@ and base_statement = string mcode (* { *) * statement dots * string mcode (* } *) | Include of string mcode (* #include *) * Ast.inc_file mcode (* file *) + | Undef of string mcode (* #define *) * ident (* name *) | Define of string mcode (* #define *) * ident (* name *) * define_parameters (*params*) * statement dots | OptStm of statement @@ -417,13 +440,13 @@ and case_line = base_case_line wrap and meta_pos = MetaPos of Ast.meta_name mcode * Ast.meta_name list * Ast.meta_collect - | NoMetaPos (* --------------------------------------------------------------------- *) (* Top-level code *) and base_top_level = - DECL of statement + NONDECL of statement + | TOPCODE of statement dots | CODE of statement dots | FILEINFO of string mcode (* old file *) * string mcode (* new file *) | ERRORWORDS of expression list @@ -447,6 +470,17 @@ and parsed_rule = (* --------------------------------------------------------------------- *) +and dependency = + Dep of string (* rule applies for the current binding *) + | AntiDep of dependency (* rule doesn't apply for the current binding *) + | EverDep of string (* rule applies for some binding *) + | NeverDep of string (* rule never applies for any binding *) + | AndDep of dependency * dependency + | OrDep of dependency * dependency + | NoDep | FailDep + +(* --------------------------------------------------------------------- *) + and anything = DotsExprTag of expression dots | DotsInitTag of initialiser dots @@ -469,6 +503,7 @@ and anything = | IsoWhenTTag of expression | IsoWhenFTag of expression | MetaPosTag of meta_pos + | HiddenVarTag of anything list (* in iso_compile/pattern only *) let dotsExpr x = DotsExprTag x let dotsParam x = DotsParamTag x @@ -498,13 +533,13 @@ let default_info _ = (* why is this a function? *) { pos_info = pos_info; attachable_start = true; attachable_end = true; mcode_start = []; mcode_end = []; - strings_before = []; strings_after = [] } + strings_before = []; strings_after = []; isSymbolIdent = false; } let default_befaft _ = MIXED(ref (Ast.NOTHING,default_token_info,default_token_info)) let context_befaft _ = CONTEXT(ref (Ast.NOTHING,default_token_info,default_token_info)) -let minus_befaft _ = MINUS(ref ([],default_token_info)) + let minus_befaft _ = MINUS(ref (Ast.NOREPLACEMENT,default_token_info)) let wrap x = { node = x; @@ -566,6 +601,39 @@ let set_mcode_data data (_,ar,info,mc,pos,adj) = (data,ar,info,mc,pos,adj) (* --------------------------------------------------------------------- *) +let rec meta_pos_name = function + HiddenVarTag(vars) -> + (* totally fake, just drop the rest, only for isos *) + meta_pos_name (List.hd vars) + | MetaPosTag(MetaPos(name,constraints,_)) -> name + | IdentTag(i) -> + (match unwrap i with + MetaId(name,constraints,seed,pure) -> name + | _ -> failwith "bad metavariable") + | ExprTag(e) -> + (match unwrap e with + MetaExpr(name,constraints,ty,form,pure) -> name + | _ -> failwith "bad metavariable") + | TypeCTag(t) -> + (match unwrap t with + MetaType(name,pure) -> name + | _ -> failwith "bad metavariable") + | DeclTag(d) -> + (match unwrap d with + MetaDecl(name,pure) -> name + | _ -> failwith "bad metavariable") + | InitTag(i) -> + (match unwrap i with + MetaInit(name,pure) -> name + | _ -> failwith "bad metavariable") + | StmtTag(s) -> + (match unwrap s with + MetaStmt(name,pure) -> name + | _ -> failwith "bad metavariable") + | _ -> failwith "bad metavariable" + +(* --------------------------------------------------------------------- *) + (* unique indices, for mcode and tree nodes *) let index_counter = ref 0 let fresh_index _ = let cur = !index_counter in index_counter := cur + 1; cur @@ -593,42 +661,43 @@ let rec ast0_type_to_type ty = | Pointer(ty,_) -> TC.Pointer(ast0_type_to_type ty) | FunctionPointer(ty,_,_,_,_,params,_) -> TC.FunctionPointer(ast0_type_to_type ty) - | FunctionType _ -> failwith "not supported" + | FunctionType _ -> TC.Unknown (*failwith "not supported"*) | Array(ety,_,_,_) -> TC.Array(ast0_type_to_type ety) | EnumName(su,Some tag) -> (match unwrap tag with Id(tag) -> TC.EnumName(TC.Name(unwrap_mcode tag)) - | MetaId(tag,_,_) -> - (Printf.printf - "warning: enum with a metavariable name detected.\n"; - Printf.printf + | MetaId(tag,_,_,_) -> + (Common.pr2_once + "warning: enum with a metavariable name detected."; + Common.pr2_once "For type checking assuming the name of the metavariable is the name of the type\n"; TC.EnumName(TC.MV(unwrap_mcode tag,TC.Unitary,false))) | _ -> failwith "unexpected enum type name") - | EnumName(su,None) -> failwith "nameless enum - what to do???" + | EnumName(su,None) -> TC.EnumName TC.NoName | EnumDef(ty,_,_,_) -> ast0_type_to_type ty | StructUnionName(su,Some tag) -> (match unwrap tag with Id(tag) -> TC.StructUnionName(structUnion su,TC.Name(unwrap_mcode tag)) - | MetaId(tag,Ast.IdNoConstraint,_) -> - (Common.pr2 - "warning: struct/union with a metavariable name detected.\n"; - Common.pr2 + | MetaId(tag,Ast.IdNoConstraint,_,_) -> + (Common.pr2_once + "warning: struct/union with a metavariable name detected."; + Common.pr2_once "For type checking assuming the name of the metavariable is the name of the type\n"; TC.StructUnionName(structUnion su, TC.MV(unwrap_mcode tag,TC.Unitary,false))) - | MetaId(tag,_,_) -> + | MetaId(tag,_,_,_) -> (* would have to duplicate the type in type_cocci.ml? perhaps polymorphism would help? *) failwith "constraints not supported on struct type name" | _ -> failwith "unexpected struct/union type name") - | StructUnionName(su,None) -> failwith "nameless structure - what to do???" + | StructUnionName(su,None) -> TC.StructUnionName(structUnion su,TC.NoName) | StructUnionDef(ty,_,_,_) -> ast0_type_to_type ty | TypeName(name) -> TC.TypeName(unwrap_mcode name) | MetaType(name,_) -> TC.MetaType(unwrap_mcode name,TC.Unitary,false) + | AsType(ty,asty) -> failwith "not created yet" | DisjType(_,types,_,_) -> Common.pr2_once "disjtype not supported in smpl type inference, assuming unknown"; @@ -640,11 +709,15 @@ and baseType = function Ast.VoidType -> TC.VoidType | Ast.CharType -> TC.CharType | Ast.ShortType -> TC.ShortType + | Ast.ShortIntType -> TC.ShortIntType | Ast.IntType -> TC.IntType | Ast.DoubleType -> TC.DoubleType + | Ast.LongDoubleType -> TC.LongDoubleType | Ast.FloatType -> TC.FloatType | Ast.LongType -> TC.LongType + | Ast.LongIntType -> TC.LongIntType | Ast.LongLongType -> TC.LongLongType + | Ast.LongLongIntType -> TC.LongLongIntType | Ast.SizeType -> TC.SizeType | Ast.SSizeType -> TC.SSizeType | Ast.PtrDiffType -> TC.PtrDiffType @@ -668,10 +741,10 @@ and const_vol t = (* this function is a rather minimal attempt. the problem is that information has been lost. but since it is only used for metavariable types in the isos, perhaps it doesn't matter *) -and make_mcode x = (x,NONE,default_info(),context_befaft(),ref NoMetaPos,-1) -let make_mcode_info x info = (x,NONE,info,context_befaft(),ref NoMetaPos,-1) +and make_mcode x = (x,NONE,default_info(),context_befaft(),ref [],-1) +let make_mcode_info x info = (x,NONE,info,context_befaft(),ref [],-1) and make_minus_mcode x = - (x,NONE,default_info(),minus_befaft(),ref NoMetaPos,-1) + (x,NONE,default_info(),minus_befaft(),ref [],-1) exception TyConv @@ -689,7 +762,7 @@ let rec reverse_type ty = | TC.EnumName(TC.MV(name,_,_)) -> EnumName (make_mcode "enum", - Some (context_wrap(MetaId(make_mcode name,Ast.IdNoConstraint, + Some (context_wrap(MetaId(make_mcode name,Ast.IdNoConstraint,Ast.NoVal, Impure)))) | TC.EnumName(TC.Name tag) -> EnumName(make_mcode "enum",Some(context_wrap(Id(make_mcode tag)))) @@ -697,7 +770,7 @@ let rec reverse_type ty = (* not right?... *) StructUnionName (reverse_structUnion su, - Some(context_wrap(MetaId(make_mcode name,Ast.IdNoConstraint, + Some(context_wrap(MetaId(make_mcode name,Ast.IdNoConstraint,Ast.NoVal, Impure(*not really right*))))) | TC.StructUnionName(su,TC.Name tag) -> StructUnionName @@ -713,11 +786,15 @@ and reverse_baseType = function | TC.CharType -> Ast.CharType | TC.BoolType -> Ast.IntType | TC.ShortType -> Ast.ShortType + | TC.ShortIntType -> Ast.ShortIntType | TC.IntType -> Ast.IntType | TC.DoubleType -> Ast.DoubleType + | TC.LongDoubleType -> Ast.LongDoubleType | TC.FloatType -> Ast.FloatType | TC.LongType -> Ast.LongType + | TC.LongIntType -> Ast.LongIntType | TC.LongLongType -> Ast.LongLongType + | TC.LongLongIntType -> Ast.LongLongIntType | TC.SizeType -> Ast.SizeType | TC.SSizeType -> Ast.SSizeType | TC.PtrDiffType -> Ast.PtrDiffType