parsing_cocci/ast_cocci.ml

   1 (*
   2  * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
   3  * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
   4  * This file is part of Coccinelle.
   5  *
   6  * Coccinelle is free software: you can redistribute it and/or modify
   7  * it under the terms of the GNU General Public License as published by
   8  * the Free Software Foundation, according to version 2 of the License.
   9  *
  10  * Coccinelle is distributed in the hope that it will be useful,
  11  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13  * GNU General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU General Public License
  16  * along with Coccinelle.  If not, see <http://www.gnu.org/licenses/>.
  17  *
  18  * The authors reserve the right to distribute this or future versions of
  19  * Coccinelle under other licenses.
  20  *)
  21
  22
  23 (* Constraints on Meta-* Identifiers, Functions *)
  24 type idconstraint =
  25     IdNoConstraint
  26   | IdNegIdSet      of string list
  27   | IdRegExp        of string * Str.regexp
  28   | IdNotRegExp     of string * Str.regexp
  29
  30 (* --------------------------------------------------------------------- *)
  31 (* Modified code *)
  32
  33 type info = { line : int; column : int;
  34               strbef : (string * int (* line *) * int (* col *)) list;
  35               straft : (string * int (* line *) * int (* col *)) list }
  36 type line = int
  37 type meta_name = string * string
  38 (* need to be careful about rewrapping, to avoid duplicating pos info
  39 currently, the pos info is always None until asttoctl2. *)
  40 type 'a wrap =
  41     {node : 'a;
  42       node_line : line;
  43       free_vars : meta_name list; (*free vars*)
  44       minus_free_vars : meta_name list; (*minus free vars*)
  45       fresh_vars : (meta_name * seed) list; (*fresh vars*)
  46       inherited : meta_name list; (*inherited vars*)
  47       saved_witness : meta_name list; (*witness vars*)
  48       bef_aft : dots_bef_aft;
  49       (* the following is for or expressions *)
  50       pos_info : meta_name mcode option; (* pos info, try not to duplicate *)
  51       true_if_test_exp : bool;(* true if "test_exp from iso", only for exprs *)
  52       (* isos relevant to the term; ultimately only used for rule_elems *)
  53       iso_info : (string*anything) list }
  54
  55 and 'a befaft =
  56     BEFORE      of 'a list list * count
  57   | AFTER       of 'a list list * count
  58   | BEFOREAFTER of 'a list list * 'a list list * count
  59   | NOTHING
  60
  61 and 'a mcode = 'a * info * mcodekind * meta_pos (* pos variable *)
  62     (* pos is an offset indicating where in the C code the mcodekind
  63        has an effect *)
  64     (* int list is the match instances, which are only meaningful in annotated
  65        C code *)
  66     (* int is the adjacency index, which is incremented on context dots *)
  67 (* iteration is only allowed on contect code, the intuition vaguely being
  68 that there is no way to replace something more than once.  Actually,
  69 allowing iterated additions on minus code would cause problems with some
  70 heuristics for adding braces, because one couldn't identify simple
  71 replacements with certainty.  Anyway, iteration doesn't seem to be needed
  72 on - code for the moment.  Although it may be confusing that there can be
  73 iterated addition of code before context code where the context code is
  74 immediately followed by removed code. *)
  75 and mcodekind =
  76     MINUS       of pos * int list * int * anything list list
  77   | CONTEXT     of pos * anything befaft
  78   | PLUS        of count
  79 and count = ONE (* + *) | MANY (* ++ *)
  80 and fixpos =
  81     Real of int (* charpos *) | Virt of int * int (* charpos + offset *)
  82 and pos = NoPos | DontCarePos | FixPos of (fixpos * fixpos)
  83
  84 and dots_bef_aft =
  85     NoDots
  86   | AddingBetweenDots of statement * int (*index of let var*)
  87   | DroppingBetweenDots of statement * int (*index of let var*)
  88
  89 and inherited = Type_cocci.inherited
  90 and keep_binding = Type_cocci.keep_binding
  91 and multi = bool (*true if a nest is one or more, false if it is zero or more*)
  92
  93 and end_info =
  94     meta_name list (*free vars*) * (meta_name * seed) list (*fresh*) *
  95       meta_name list (*inherited vars*) * mcodekind
  96
  97 (* --------------------------------------------------------------------- *)
  98 (* Metavariables *)
  99
 100 and arity = UNIQUE | OPT | MULTI | NONE
 101
 102 and metavar =
 103     MetaIdDecl of arity * meta_name (* name *)
 104   | MetaFreshIdDecl of meta_name (* name *) * seed (* seed *)
 105   | MetaTypeDecl of arity * meta_name (* name *)
 106   | MetaInitDecl of arity * meta_name (* name *)
 107   | MetaListlenDecl of meta_name (* name *)
 108   | MetaParamDecl of arity * meta_name (* name *)
 109   | MetaParamListDecl of arity * meta_name (*name*) * meta_name option (*len*)
 110   | MetaConstDecl of
 111       arity * meta_name (* name *) * Type_cocci.typeC list option
 112   | MetaErrDecl of arity * meta_name (* name *)
 113   | MetaExpDecl of
 114       arity * meta_name (* name *) * Type_cocci.typeC list option
 115   | MetaIdExpDecl of
 116       arity * meta_name (* name *) * Type_cocci.typeC list option
 117   | MetaLocalIdExpDecl of
 118       arity * meta_name (* name *) * Type_cocci.typeC list option
 119   | MetaExpListDecl of arity * meta_name (*name*) * meta_name option (*len*)
 120   | MetaStmDecl of arity * meta_name (* name *)
 121   | MetaStmListDecl of arity * meta_name (* name *)
 122   | MetaFuncDecl of arity * meta_name (* name *)
 123   | MetaLocalFuncDecl of arity * meta_name (* name *)
 124   | MetaPosDecl of arity * meta_name (* name *)
 125   | MetaDeclarerDecl of arity * meta_name (* name *)
 126   | MetaIteratorDecl of arity * meta_name (* name *)
 127
 128 and seed = NoVal | StringSeed of string | ListSeed of seed_elem list
 129 and seed_elem = SeedString of string | SeedId of meta_name
 130
 131 (* --------------------------------------------------------------------- *)
 132 (* --------------------------------------------------------------------- *)
 133 (* Dots *)
 134
 135 and 'a base_dots =
 136     DOTS of 'a list
 137   | CIRCLES of 'a list
 138   | STARS of 'a list
 139
 140 and 'a dots = 'a base_dots wrap
 141
 142 (* --------------------------------------------------------------------- *)
 143 (* Identifier *)
 144
 145 and base_ident =
 146     Id            of string mcode
 147   | MetaId        of meta_name mcode * idconstraint * keep_binding * inherited
 148   | MetaFunc      of meta_name mcode * idconstraint * keep_binding * inherited
 149   | MetaLocalFunc of meta_name mcode * idconstraint * keep_binding * inherited
 150
 151   | OptIdent      of ident
 152   | UniqueIdent   of ident
 153
 154 and ident = base_ident wrap
 155
 156 (* --------------------------------------------------------------------- *)
 157 (* Expression *)
 158
 159 and base_expression =
 160     Ident          of ident
 161   | Constant       of constant mcode
 162   | FunCall        of expression * string mcode (* ( *) *
 163                       expression dots * string mcode (* ) *)
 164   | Assignment     of expression * assignOp mcode * expression *
 165                       bool (* true if it can match an initialization *)
 166   | CondExpr       of expression * string mcode (* ? *) * expression option *
 167                       string mcode (* : *) * expression
 168   | Postfix        of expression * fixOp mcode
 169   | Infix          of expression * fixOp mcode
 170   | Unary          of expression * unaryOp mcode
 171   | Binary         of expression * binaryOp mcode * expression
 172   | Nested         of expression * binaryOp mcode * expression
 173   | ArrayAccess    of expression * string mcode (* [ *) * expression *
 174                       string mcode (* ] *)
 175   | RecordAccess   of expression * string mcode (* . *) * ident
 176   | RecordPtAccess of expression * string mcode (* -> *) * ident
 177   | Cast           of string mcode (* ( *) * fullType * string mcode (* ) *) *
 178                       expression
 179   | SizeOfExpr     of string mcode (* sizeof *) * expression
 180   | SizeOfType     of string mcode (* sizeof *) * string mcode (* ( *) *
 181                       fullType * string mcode (* ) *)
 182   | TypeExp        of fullType (*type name used as an expression, only in
 183                                   arg or #define*)
 184
 185   | Paren          of string mcode (* ( *) * expression *
 186                       string mcode (* ) *)
 187
 188   | MetaErr        of meta_name mcode * constraints * keep_binding *
 189                       inherited
 190   | MetaExpr       of meta_name mcode * constraints * keep_binding *
 191                       Type_cocci.typeC list option * form * inherited
 192   | MetaExprList   of meta_name mcode * listlen option * keep_binding *
 193                       inherited (* only in arg lists *)
 194
 195   | EComma         of string mcode (* only in arg lists *)
 196
 197   | DisjExpr       of expression list
 198   | NestExpr       of expression dots * expression option * multi
 199
 200   (* can appear in arg lists, and also inside Nest, as in:
 201    if(< ... X ... Y ...>)
 202    In the following, the expression option is the WHEN  *)
 203   | Edots          of string mcode (* ... *) * expression option
 204   | Ecircles       of string mcode (* ooo *) * expression option
 205   | Estars         of string mcode (* *** *) * expression option
 206
 207   | OptExp         of expression
 208   | UniqueExp      of expression
 209
 210 and constraints =
 211     NoConstraint
 212   | NotIdCstrt     of idconstraint
 213   | NotExpCstrt    of expression list
 214
 215 (* ANY = int E; ID = idexpression int X; CONST = constant int X; *)
 216 and form = ANY | ID | LocalID | CONST (* form for MetaExp *)
 217
 218 and expression = base_expression wrap
 219
 220 and listlen = meta_name mcode * keep_binding * inherited
 221
 222 and  unaryOp = GetRef | DeRef | UnPlus |  UnMinus | Tilde | Not
 223 and  assignOp = SimpleAssign | OpAssign of arithOp
 224 and  fixOp = Dec | Inc
 225
 226 and  binaryOp = Arith of arithOp | Logical of logicalOp
 227 and  arithOp =
 228     Plus | Minus | Mul | Div | Mod | DecLeft | DecRight | And | Or | Xor
 229 and  logicalOp = Inf | Sup | InfEq | SupEq | Eq | NotEq | AndLog | OrLog
 230
 231 and constant =
 232     String of string
 233   | Char   of string
 234   | Int    of string
 235   | Float  of string
 236
 237 (* --------------------------------------------------------------------- *)
 238 (* Types *)
 239
 240 and base_fullType =
 241     Type            of const_vol mcode option * typeC
 242   | DisjType        of fullType list (* only after iso *)
 243   | OptType         of fullType
 244   | UniqueType      of fullType
 245
 246 and base_typeC =
 247     BaseType        of baseType * string mcode list (* Yoann style *)
 248   | SignedT         of sign mcode * typeC option
 249   | Pointer         of fullType * string mcode (* * *)
 250   | FunctionPointer of fullType *
 251                   string mcode(* ( *)*string mcode(* * *)*string mcode(* ) *)*
 252                   string mcode (* ( *)*parameter_list*string mcode(* ) *)
 253
 254   (* used for the automatic managment of prototypes *)
 255   | FunctionType     of bool (* true if all minus for dropping return type *) *
 256                    fullType option *
 257                    string mcode (* ( *) * parameter_list *
 258                    string mcode (* ) *)
 259
 260   | Array           of fullType * string mcode (* [ *) *
 261                        expression option * string mcode (* ] *)
 262   | EnumName        of string mcode (*enum*) * ident (* name *)
 263   | StructUnionName of structUnion mcode * ident option (* name *)
 264   | StructUnionDef  of fullType (* either StructUnionName or metavar *) *
 265         string mcode (* { *) * declaration dots * string mcode (* } *)
 266   | TypeName        of string mcode (* pad: should be 'of ident' ? *)
 267
 268   | MetaType        of meta_name mcode * keep_binding * inherited
 269
 270 and fullType = base_fullType wrap
 271 and typeC = base_typeC wrap
 272
 273 and baseType = VoidType | CharType | ShortType | IntType | DoubleType
 274   | FloatType | LongType | LongLongType
 275
 276 and structUnion = Struct | Union
 277
 278 and sign = Signed | Unsigned
 279
 280 and const_vol = Const | Volatile
 281
 282 (* --------------------------------------------------------------------- *)
 283 (* Variable declaration *)
 284 (* Even if the Cocci program specifies a list of declarations, they are
 285    split out into multiple declarations of a single variable each. *)
 286
 287 and base_declaration =
 288     Init of storage mcode option * fullType * ident * string mcode (*=*) *
 289         initialiser * string mcode (*;*)
 290   | UnInit of storage mcode option * fullType * ident * string mcode (* ; *)
 291   | TyDecl of fullType * string mcode (* ; *)
 292   | MacroDecl of ident (* name *) * string mcode (* ( *) *
 293         expression dots * string mcode (* ) *) * string mcode (* ; *)
 294   | Typedef of string mcode (*typedef*) * fullType *
 295                typeC (* either TypeName or metavar *) * string mcode (*;*)
 296   | DisjDecl of declaration list
 297   (* Ddots is for a structure declaration *)
 298   | Ddots    of string mcode (* ... *) * declaration option (* whencode *)
 299
 300   | MetaDecl of meta_name mcode * keep_binding * inherited
 301
 302   | OptDecl    of declaration
 303   | UniqueDecl of declaration
 304
 305 and declaration = base_declaration wrap
 306
 307 (* --------------------------------------------------------------------- *)
 308 (* Initializers *)
 309
 310 and base_initialiser =
 311     MetaInit of meta_name mcode * keep_binding * inherited
 312   | InitExpr of expression
 313   | InitList of string mcode (*{*) * initialiser list * string mcode (*}*) *
 314         initialiser list (* whencode: elements that shouldn't appear in init *)
 315   | InitGccExt of
 316       designator list (* name *) * string mcode (*=*) *
 317         initialiser (* gccext: *)
 318   | InitGccName of ident (* name *) * string mcode (*:*) *
 319         initialiser
 320   | IComma of string mcode (* , *)
 321
 322   | OptIni    of initialiser
 323   | UniqueIni of initialiser
 324
 325 and designator =
 326     DesignatorField of string mcode (* . *) * ident
 327   | DesignatorIndex of string mcode (* [ *) * expression * string mcode (* ] *)
 328   | DesignatorRange of
 329       string mcode (* [ *) * expression * string mcode (* ... *) *
 330       expression * string mcode (* ] *)
 331
 332 and initialiser = base_initialiser wrap
 333
 334 (* --------------------------------------------------------------------- *)
 335 (* Parameter *)
 336
 337 and base_parameterTypeDef =
 338     VoidParam     of fullType
 339   | Param         of fullType * ident option
 340
 341   | MetaParam     of meta_name mcode * keep_binding * inherited
 342   | MetaParamList of meta_name mcode * listlen option * keep_binding *
 343                      inherited
 344
 345   | PComma        of string mcode
 346
 347   | Pdots         of string mcode (* ... *)
 348   | Pcircles      of string mcode (* ooo *)
 349
 350   | OptParam      of parameterTypeDef
 351   | UniqueParam   of parameterTypeDef
 352
 353 and parameterTypeDef = base_parameterTypeDef wrap
 354
 355 and parameter_list = parameterTypeDef dots
 356
 357 (* --------------------------------------------------------------------- *)
 358 (* #define Parameters *)
 359
 360 and base_define_param =
 361     DParam        of ident
 362   | DPComma       of string mcode
 363   | DPdots        of string mcode (* ... *)
 364   | DPcircles     of string mcode (* ooo *)
 365   | OptDParam     of define_param
 366   | UniqueDParam  of define_param
 367
 368 and define_param = base_define_param wrap
 369
 370 and base_define_parameters =
 371     NoParams     (* not parameter list, not an empty one *)
 372   | DParams      of string mcode(*( *) * define_param dots * string mcode(* )*)
 373
 374 and define_parameters = base_define_parameters wrap
 375
 376 (* --------------------------------------------------------------------- *)
 377 (* positions *)
 378
 379 (* PER = keep bindings separate, ALL = collect them *)
 380 and meta_collect = PER | ALL
 381
 382 and meta_pos =
 383     MetaPos of meta_name mcode * meta_name list *
 384         meta_collect * keep_binding * inherited
 385   | NoMetaPos
 386
 387 (* --------------------------------------------------------------------- *)
 388 (* Function declaration *)
 389
 390 and storage = Static | Auto | Register | Extern
 391
 392 (* --------------------------------------------------------------------- *)
 393 (* Top-level code *)
 394
 395 and base_rule_elem =
 396     FunHeader     of mcodekind (* before the function header *) *
 397                      bool (* true if all minus, for dropping static, etc *) *
 398                      fninfo list * ident (* name *) *
 399                      string mcode (* ( *) * parameter_list *
 400                      string mcode (* ) *)
 401   | Decl          of mcodekind (* before the decl *) *
 402                      bool (* true if all minus *) * declaration
 403
 404   | SeqStart      of string mcode (* { *)
 405   | SeqEnd        of string mcode (* } *)
 406
 407   | ExprStatement of expression * string mcode (*;*)
 408   | IfHeader      of string mcode (* if *) * string mcode (* ( *) *
 409                      expression * string mcode (* ) *)
 410   | Else          of string mcode (* else *)
 411   | WhileHeader   of string mcode (* while *) * string mcode (* ( *) *
 412                      expression * string mcode (* ) *)
 413   | DoHeader      of string mcode (* do *)
 414   | WhileTail     of string mcode (* while *) * string mcode (* ( *) *
 415                      expression * string mcode (* ) *) *
 416                      string mcode (* ; *)
 417   | ForHeader     of string mcode (* for *) * string mcode (* ( *) *
 418                      expression option * string mcode (*;*) *
 419                      expression option * string mcode (*;*) *
 420                      expression option * string mcode (* ) *)
 421   | IteratorHeader of ident (* name *) * string mcode (* ( *) *
 422                      expression dots * string mcode (* ) *)
 423   | SwitchHeader  of string mcode (* switch *) * string mcode (* ( *) *
 424                      expression * string mcode (* ) *)
 425   | Break         of string mcode (* break *) * string mcode (* ; *)
 426   | Continue      of string mcode (* continue *) * string mcode (* ; *)
 427   | Label         of ident * string mcode (* : *)
 428   | Goto          of string mcode (* goto *) * ident * string mcode (* ; *)
 429   | Return        of string mcode (* return *) * string mcode (* ; *)
 430   | ReturnExpr    of string mcode (* return *) * expression *
 431                      string mcode (* ; *)
 432
 433   | MetaRuleElem  of meta_name mcode * keep_binding * inherited
 434   | MetaStmt      of meta_name mcode * keep_binding * metaStmtInfo *
 435                      inherited
 436   | MetaStmtList  of meta_name mcode * keep_binding * inherited
 437
 438   | Exp           of expression (* matches a subterm *)
 439   | TopExp        of expression (* for macros body, exp at top level,
 440                                    not subexp *)
 441   | Ty            of fullType (* only at SP top level, matches a subterm *)
 442   | TopInit       of initialiser (* only at top level *)
 443   | Include       of string mcode (*#include*) * inc_file mcode (*file *)
 444   | DefineHeader  of string mcode (* #define *) * ident (* name *) *
 445                      define_parameters (*params*)
 446   | Case          of string mcode (* case *) * expression * string mcode (*:*)
 447   | Default       of string mcode (* default *) * string mcode (*:*)
 448   | DisjRuleElem  of rule_elem list
 449
 450 and fninfo =
 451     FStorage of storage mcode
 452   | FType of fullType
 453   | FInline of string mcode
 454   | FAttr of string mcode
 455
 456 and metaStmtInfo =
 457     NotSequencible | SequencibleAfterDots of dots_whencode list | Sequencible
 458
 459 and rule_elem = base_rule_elem wrap
 460
 461 and base_statement =
 462     Seq           of rule_elem (* { *) *
 463                      statement dots * rule_elem (* } *)
 464   | IfThen        of rule_elem (* header *) * statement * end_info (* endif *)
 465   | IfThenElse    of rule_elem (* header *) * statement *
 466                      rule_elem (* else *) * statement * end_info (* endif *)
 467   | While         of rule_elem (* header *) * statement * end_info (*endwhile*)
 468   | Do            of rule_elem (* do *) * statement * rule_elem (* tail *)
 469   | For           of rule_elem (* header *) * statement * end_info (*endfor*)
 470   | Iterator      of rule_elem (* header *) * statement * end_info (*enditer*)
 471   | Switch        of rule_elem (* header *) * rule_elem (* { *) *
 472                      statement (*decl*) dots * case_line list * rule_elem(*}*)
 473   | Atomic        of rule_elem
 474   | Disj          of statement dots list
 475   | Nest          of statement dots *
 476                      (statement dots,statement) whencode list * multi *
 477                      dots_whencode list * dots_whencode list
 478   | FunDecl       of rule_elem (* header *) * rule_elem (* { *) *
 479                      statement dots * rule_elem (* } *)
 480   | Define        of rule_elem (* header *) * statement dots
 481   | Dots          of string mcode (* ... *) *
 482                      (statement dots,statement) whencode list *
 483                      dots_whencode list * dots_whencode list
 484   | Circles       of string mcode (* ooo *) *
 485                      (statement dots,statement) whencode list *
 486                      dots_whencode list * dots_whencode list
 487   | Stars         of string mcode (* *** *) *
 488                      (statement dots,statement) whencode list *
 489                      dots_whencode list * dots_whencode list
 490   | OptStm        of statement
 491   | UniqueStm     of statement
 492
 493 and ('a,'b) whencode =
 494     WhenNot of 'a
 495   | WhenAlways of 'b
 496   | WhenModifier of when_modifier
 497   | WhenNotTrue of rule_elem (* useful for fvs *)
 498   | WhenNotFalse of rule_elem
 499
 500 and when_modifier =
 501   (* The following removes the shortest path constraint.  It can be used
 502      with other when modifiers *)
 503     WhenAny
 504   (* The following removes the special consideration of error paths.  It
 505      can be used with other when modifiers *)
 506   | WhenStrict
 507   | WhenForall
 508   | WhenExists
 509
 510 (* only used with asttoctl *)
 511 and dots_whencode =
 512     WParen of rule_elem * meta_name (*pren_var*)
 513   | Other of statement
 514   | Other_dots of statement dots
 515
 516 and statement = base_statement wrap
 517
 518 and base_case_line =
 519     CaseLine of rule_elem (* case/default header *) * statement dots
 520   | OptCase of case_line
 521
 522 and case_line = base_case_line wrap
 523
 524 and inc_file =
 525     Local of inc_elem list
 526   | NonLocal of inc_elem list
 527
 528 and inc_elem =
 529     IncPath of string
 530   | IncDots
 531
 532 and base_top_level =
 533     DECL of statement
 534   | CODE of statement dots
 535   | FILEINFO of string mcode (* old file *) * string mcode (* new file *)
 536   | ERRORWORDS of expression list
 537
 538 and top_level = base_top_level wrap
 539
 540 and rulename =
 541     CocciRulename of string option * dependency *
 542         string list * string list * exists * bool
 543   | GeneratedRulename of string option * dependency *
 544         string list * string list * exists * bool
 545   | ScriptRulename of string * dependency
 546   | InitialScriptRulename of string
 547   | FinalScriptRulename of string
 548
 549 and ruletype = Normal | Generated
 550
 551 and rule =
 552     CocciRule of string (* name *) *
 553         (dependency * string list (* dropped isos *) * exists) * top_level list
 554         * bool list * ruletype
 555   | ScriptRule of string * dependency * (string * meta_name) list * string
 556   | InitialScriptRule of string (*language*) * string (*code*)
 557   | FinalScriptRule of string (*language*) * string (*code*)
 558
 559 and dependency =
 560     Dep of string (* rule applies for the current binding *)
 561   | AntiDep of string (* rule doesn't apply for the current binding *)
 562   | EverDep of string (* rule applies for some binding *)
 563   | NeverDep of string (* rule never applies for any binding *)
 564   | AndDep of dependency * dependency
 565   | OrDep of dependency * dependency
 566   | NoDep | FailDep
 567
 568 and rule_with_metavars = metavar list * rule
 569
 570 and anything =
 571     FullTypeTag         of fullType
 572   | BaseTypeTag         of baseType
 573   | StructUnionTag      of structUnion
 574   | SignTag             of sign
 575   | IdentTag            of ident
 576   | ExpressionTag       of expression
 577   | ConstantTag         of constant
 578   | UnaryOpTag          of unaryOp
 579   | AssignOpTag         of assignOp
 580   | FixOpTag            of fixOp
 581   | BinaryOpTag         of binaryOp
 582   | ArithOpTag          of arithOp
 583   | LogicalOpTag        of logicalOp
 584   | DeclarationTag      of declaration
 585   | InitTag             of initialiser
 586   | StorageTag          of storage
 587   | IncFileTag          of inc_file
 588   | Rule_elemTag        of rule_elem
 589   | StatementTag        of statement
 590   | CaseLineTag         of case_line
 591   | ConstVolTag         of const_vol
 592   | Token               of string * info option
 593   | Pragma              of string list
 594   | Code                of top_level
 595   | ExprDotsTag         of expression dots
 596   | ParamDotsTag        of parameterTypeDef dots
 597   | StmtDotsTag         of statement dots
 598   | DeclDotsTag         of declaration dots
 599   | TypeCTag            of typeC
 600   | ParamTag            of parameterTypeDef
 601   | SgrepStartTag       of string
 602   | SgrepEndTag         of string
 603
 604 (* --------------------------------------------------------------------- *)
 605
 606 and exists = Exists | Forall | Undetermined
 607 (* | ReverseForall - idea: look back on all flow paths; not implemented *)
 608
 609 (* --------------------------------------------------------------------- *)
 610
 611 let mkToken x = Token (x,None)
 612
 613 (* --------------------------------------------------------------------- *)
 614
 615 let lub_count i1 i2 =
 616   match (i1,i2) with
 617     (MANY,MANY) -> MANY
 618   | _ -> ONE
 619
 620 (* --------------------------------------------------------------------- *)
 621
 622 let rewrap model x         = {model with node = x}
 623 let rewrap_mcode (_,a,b,c) x = (x,a,b,c)
 624 let unwrap x               = x.node
 625 let unwrap_mcode (x,_,_,_)  = x
 626 let get_mcodekind (_,_,x,_) = x
 627 let get_line x             = x.node_line
 628 let get_mcode_line (_,l,_,_) = l.line
 629 let get_mcode_col (_,l,_,_)  = l.column
 630 let get_fvs x              = x.free_vars
 631 let set_fvs fvs x          = {x with free_vars = fvs}
 632 let get_mfvs x             = x.minus_free_vars
 633 let set_mfvs mfvs x        = {x with minus_free_vars = mfvs}
 634 let get_fresh x            = x.fresh_vars
 635 let get_inherited x        = x.inherited
 636 let get_saved x            = x.saved_witness
 637 let get_dots_bef_aft x     = x.bef_aft
 638 let set_dots_bef_aft d x   = {x with bef_aft = d}
 639 let get_pos x              = x.pos_info
 640 let set_pos x pos          = {x with pos_info = pos}
 641 let get_test_exp x      = x.true_if_test_exp
 642 let set_test_exp x      = {x with true_if_test_exp = true}
 643 let get_isos x             = x.iso_info
 644 let set_isos x isos        = {x with iso_info = isos}
 645 let get_pos_var (_,_,_,p)  = p
 646 let set_pos_var vr (a,b,c,_) = (a,b,c,vr)
 647 let drop_pos (a,b,c,_)     = (a,b,c,NoMetaPos)
 648
 649 let get_wcfvs (whencode : ('a wrap, 'b wrap) whencode list) =
 650   Common.union_all
 651     (List.map
 652        (function
 653            WhenNot(a) -> get_fvs a
 654          | WhenAlways(a) -> get_fvs a
 655          | WhenModifier(_) -> []
 656          | WhenNotTrue(e) -> get_fvs e
 657          | WhenNotFalse(e) -> get_fvs e)
 658        whencode)
 659
 660 (* --------------------------------------------------------------------- *)
 661
 662 let get_meta_name = function
 663     MetaIdDecl(ar,nm) -> nm
 664   | MetaFreshIdDecl(nm,seed) -> nm
 665   | MetaTypeDecl(ar,nm) -> nm
 666   | MetaInitDecl(ar,nm) -> nm
 667   | MetaListlenDecl(nm) -> nm
 668   | MetaParamDecl(ar,nm) -> nm
 669   | MetaParamListDecl(ar,nm,nm1) -> nm
 670   | MetaConstDecl(ar,nm,ty) -> nm
 671   | MetaErrDecl(ar,nm) -> nm
 672   | MetaExpDecl(ar,nm,ty) -> nm
 673   | MetaIdExpDecl(ar,nm,ty) -> nm
 674   | MetaLocalIdExpDecl(ar,nm,ty) -> nm
 675   | MetaExpListDecl(ar,nm,nm1) -> nm
 676   | MetaStmDecl(ar,nm) -> nm
 677   | MetaStmListDecl(ar,nm) -> nm
 678   | MetaFuncDecl(ar,nm) -> nm
 679   | MetaLocalFuncDecl(ar,nm) -> nm
 680   | MetaPosDecl(ar,nm) -> nm
 681   | MetaDeclarerDecl(ar,nm) -> nm
 682   | MetaIteratorDecl(ar,nm) -> nm
 683
 684 (* --------------------------------------------------------------------- *)
 685
 686 and tag2c = function
 687     FullTypeTag _ -> "FullTypeTag"
 688   | BaseTypeTag _ -> "BaseTypeTag"
 689   | StructUnionTag _ -> "StructUnionTag"
 690   | SignTag _ -> "SignTag"
 691   | IdentTag _ -> "IdentTag"
 692   | ExpressionTag _ -> "ExpressionTag"
 693   | ConstantTag _ -> "ConstantTag"
 694   | UnaryOpTag _ -> "UnaryOpTag"
 695   | AssignOpTag _ -> "AssignOpTag"
 696   | FixOpTag _ -> "FixOpTag"
 697   | BinaryOpTag _ -> "BinaryOpTag"
 698   | ArithOpTag _ -> "ArithOpTag"
 699   | LogicalOpTag _ -> "LogicalOpTag"
 700   | DeclarationTag _ -> "DeclarationTag"
 701   | InitTag _ -> "InitTag"
 702   | StorageTag _ -> "StorageTag"
 703   | IncFileTag _ -> "IncFileTag"
 704   | Rule_elemTag _ -> "Rule_elemTag"
 705   | StatementTag _ -> "StatementTag"
 706   | CaseLineTag _ -> "CaseLineTag"
 707   | ConstVolTag _ -> "ConstVolTag"
 708   | Token _ -> "Token"
 709   | Pragma _ -> "Pragma"
 710   | Code _ -> "Code"
 711   | ExprDotsTag _ -> "ExprDotsTag"
 712   | ParamDotsTag _ -> "ParamDotsTag"
 713   | StmtDotsTag _ -> "StmtDotsTag"
 714   | DeclDotsTag _ -> "DeclDotsTag"
 715   | TypeCTag _ -> "TypeCTag"
 716   | ParamTag _ -> "ParamTag"
 717   | SgrepStartTag _ -> "SgrepStartTag"
 718   | SgrepEndTag _ -> "SgrepEndTag"
 719
 720 (* --------------------------------------------------------------------- *)
 721
 722 let no_info = { line = 0; column = -1; strbef = []; straft = [] }
 723
 724 let make_term x =
 725   {node = x;
 726     node_line = 0;
 727     free_vars = [];
 728     minus_free_vars = [];
 729     fresh_vars = [];
 730     inherited = [];
 731     saved_witness = [];
 732     bef_aft = NoDots;
 733     pos_info = None;
 734     true_if_test_exp = false;
 735     iso_info = [] }
 736
 737 let make_meta_rule_elem s d (fvs,fresh,inh) =
 738   {(make_term
 739       (MetaRuleElem((("",s),no_info,d,NoMetaPos),Type_cocci.Unitary,false)))
 740   with free_vars = fvs; fresh_vars = fresh; inherited = inh}
 741
 742 let make_meta_decl s d (fvs,fresh,inh) =
 743   {(make_term
 744       (MetaDecl((("",s),no_info,d,NoMetaPos),Type_cocci.Unitary,false))) with
 745     free_vars = fvs; fresh_vars = fresh; inherited = inh}
 746
 747 let make_mcode x = (x,no_info,CONTEXT(NoPos,NOTHING),NoMetaPos)
 748
 749 (* --------------------------------------------------------------------- *)
 750
 751 let equal_pos x y = x = y
 752
 753 (* --------------------------------------------------------------------- *)
 754
 755 let undots x =
 756   match unwrap x with
 757     DOTS    e -> e
 758   | CIRCLES e -> e
 759   | STARS   e -> e