parsing_cocci/ast0_cocci.ml

   1 (*
   2  * Copyright 2012, INRIA
   3  * Julia Lawall, Gilles Muller
   4  * Copyright 2010-2011, INRIA, University of Copenhagen
   5  * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
   6  * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
   7  * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
   8  * This file is part of Coccinelle.
   9  *
  10  * Coccinelle is free software: you can redistribute it and/or modify
  11  * it under the terms of the GNU General Public License as published by
  12  * the Free Software Foundation, according to version 2 of the License.
  13  *
  14  * Coccinelle is distributed in the hope that it will be useful,
  15  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  16  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17  * GNU General Public License for more details.
  18  *
  19  * You should have received a copy of the GNU General Public License
  20  * along with Coccinelle.  If not, see <http://www.gnu.org/licenses/>.
  21  *
  22  * The authors reserve the right to distribute this or future versions of
  23  * Coccinelle under other licenses.
  24  *)
  25
  26
  27 module Ast = Ast_cocci
  28 module TC = Type_cocci
  29
  30 (* --------------------------------------------------------------------- *)
  31 (* Modified code *)
  32
  33 type arity = OPT | UNIQUE | NONE
  34
  35 type token_info =
  36     { tline_start : int; tline_end : int;
  37       left_offset : int; right_offset : int }
  38 let default_token_info =
  39   { tline_start = -1; tline_end = -1; left_offset = -1; right_offset = -1 }
  40
  41 (* MIXED is like CONTEXT, since sometimes MIXED things have to revert to
  42 CONTEXT - see insert_plus.ml *)
  43
  44 type mcodekind =
  45     MINUS       of (Ast.anything Ast.replacement * token_info) ref
  46   | PLUS        of Ast.count
  47   | CONTEXT     of (Ast.anything Ast.befaft * token_info * token_info) ref
  48   | MIXED       of (Ast.anything Ast.befaft * token_info * token_info) ref
  49
  50 type position_info = { line_start : int; line_end : int;
  51                        logical_start : int; logical_end : int;
  52                        column : int; offset : int; }
  53
  54 type info = { pos_info : position_info;
  55               attachable_start : bool; attachable_end : bool;
  56               mcode_start : mcodekind list; mcode_end : mcodekind list;
  57               (* the following are only for + code *)
  58               strings_before : (Ast.added_string * position_info) list;
  59               strings_after : (Ast.added_string * position_info) list;
  60               isSymbolIdent : bool; (* is the token a symbol identifier or not *) }
  61
  62 (* adjacency index is incremented when we skip over dots or nest delimiters
  63 it is used in deciding how much to remove, when two adjacent code tokens are
  64 removed. *)
  65 type 'a mcode =
  66     'a * arity * info * mcodekind * anything list ref (* pos, - only *) *
  67       int (* adjacency_index *)
  68 (* int ref is an index *)
  69 and 'a wrap =
  70     { node : 'a;
  71       info : info;
  72       index : int ref;
  73       mcodekind : mcodekind ref;
  74       exp_ty : TC.typeC option ref; (* only for expressions *)
  75       bef_aft : dots_bef_aft; (* only for statements *)
  76       true_if_arg : bool; (* true if "arg_exp", only for exprs *)
  77       true_if_test : bool; (* true if "test position", only for exprs *)
  78       true_if_test_exp : bool;(* true if "test_exp from iso", only for exprs *)
  79       (*nonempty if this represents the use of an iso*)
  80       iso_info : (string*anything) list }
  81
  82 and dots_bef_aft =
  83     NoDots | AddingBetweenDots of statement | DroppingBetweenDots of statement
  84
  85 (* for iso metavariables, true if they can only match nonmodified terms with
  86    all metavariables unitary
  87    for SP metavariables, true if the metavariable is unitary (valid up to
  88    isomorphism phase only)
  89    In SP, the only options are impure and context
  90 *)
  91 and pure = Impure | Pure | Context | PureContext (* pure and only context *)
  92
  93 (* --------------------------------------------------------------------- *)
  94 (* --------------------------------------------------------------------- *)
  95 (* Dots *)
  96
  97 and 'a base_dots =
  98     DOTS of 'a list
  99   | CIRCLES of 'a list
 100   | STARS of 'a list
 101
 102 and 'a dots = 'a base_dots wrap
 103
 104 (* --------------------------------------------------------------------- *)
 105 (* Identifier *)
 106
 107 and base_ident =
 108     Id            of string mcode
 109   | MetaId        of Ast.meta_name mcode * Ast.idconstraint * Ast.seed * pure
 110   | MetaFunc      of Ast.meta_name mcode * Ast.idconstraint * pure
 111   | MetaLocalFunc of Ast.meta_name mcode * Ast.idconstraint * pure
 112   | DisjId        of string mcode * ident list *
 113                      string mcode list (* the |s *) * string mcode
 114   | OptIdent      of ident
 115   | UniqueIdent   of ident
 116
 117 and ident = base_ident wrap
 118
 119 (* --------------------------------------------------------------------- *)
 120 (* Expression *)
 121
 122 and base_expression =
 123     Ident          of ident
 124   | Constant       of Ast.constant mcode
 125   | FunCall        of expression * string mcode (* ( *) *
 126                       expression dots * string mcode (* ) *)
 127   | Assignment     of expression * Ast.assignOp mcode * expression *
 128                       bool (* true if it can match an initialization *)
 129   | Sequence       of expression * string mcode (* , *) * expression
 130   | CondExpr       of expression * string mcode (* ? *) * expression option *
 131                       string mcode (* : *) * expression
 132   | Postfix        of expression * Ast.fixOp mcode
 133   | Infix          of expression * Ast.fixOp mcode
 134   | Unary          of expression * Ast.unaryOp mcode
 135   | Binary         of expression * Ast.binaryOp mcode * expression
 136   | Nested         of expression * Ast.binaryOp mcode * expression
 137   | Paren          of string mcode (* ( *) * expression *
 138                       string mcode (* ) *)
 139   | ArrayAccess    of expression * string mcode (* [ *) * expression *
 140                       string mcode (* ] *)
 141   | RecordAccess   of expression * string mcode (* . *) * ident
 142   | RecordPtAccess of expression * string mcode (* -> *) * ident
 143   | Cast           of string mcode (* ( *) * typeC * string mcode (* ) *) *
 144                       expression
 145   | SizeOfExpr     of string mcode (* sizeof *) * expression
 146   | SizeOfType     of string mcode (* sizeof *) * string mcode (* ( *) *
 147                       typeC * string mcode (* ) *)
 148   | TypeExp        of typeC (* type name used as an expression, only in args *)
 149   | Constructor    of string mcode (* ( *) * typeC * string mcode (* ) *) *
 150                       initialiser
 151   | MetaErr        of Ast.meta_name mcode * constraints * pure
 152   | MetaExpr       of Ast.meta_name mcode * constraints *
 153                       TC.typeC list option * Ast.form * pure
 154   | MetaExprList   of Ast.meta_name mcode (* only in arg lists *) *
 155                       listlen * pure
 156   | AsExpr         of expression * expression (* as expr, always metavar *)
 157   | EComma         of string mcode (* only in arg lists *)
 158   | DisjExpr       of string mcode * expression list *
 159                       string mcode list (* the |s *) * string mcode
 160   | NestExpr       of string mcode * expression dots * string mcode *
 161                       expression option * Ast.multi
 162   | Edots          of string mcode (* ... *) * expression option
 163   | Ecircles       of string mcode (* ooo *) * expression option
 164   | Estars         of string mcode (* *** *) * expression option
 165   | OptExp         of expression
 166   | UniqueExp      of expression
 167
 168 and expression = base_expression wrap
 169
 170 and constraints =
 171     NoConstraint
 172   | NotIdCstrt     of Ast.reconstraint
 173   | NotExpCstrt    of expression list
 174   | SubExpCstrt    of Ast.meta_name list
 175
 176 and listlen =
 177     MetaListLen of Ast.meta_name mcode
 178   | CstListLen of int
 179   | AnyListLen
 180
 181 (* --------------------------------------------------------------------- *)
 182 (* Types *)
 183
 184 and base_typeC =
 185     ConstVol        of Ast.const_vol mcode * typeC
 186   | BaseType        of Ast.baseType * string mcode list
 187   | Signed          of Ast.sign mcode * typeC option
 188   | Pointer         of typeC * string mcode (* * *)
 189   | FunctionPointer of typeC *
 190                   string mcode(* ( *)*string mcode(* * *)*string mcode(* ) *)*
 191                   string mcode (* ( *)*parameter_list*string mcode(* ) *)
 192   | FunctionType    of typeC option *
 193                        string mcode (* ( *) * parameter_list *
 194                        string mcode (* ) *)
 195   | Array           of typeC * string mcode (* [ *) *
 196                        expression option * string mcode (* ] *)
 197   | EnumName        of string mcode (*enum*) * ident option (* name *)
 198   | EnumDef  of typeC (* either StructUnionName or metavar *) *
 199         string mcode (* { *) * expression dots * string mcode (* } *)
 200   | StructUnionName of Ast.structUnion mcode * ident option (* name *)
 201   | StructUnionDef  of typeC (* either StructUnionName or metavar *) *
 202         string mcode (* { *) * declaration dots * string mcode (* } *)
 203   | TypeName        of string mcode
 204   | MetaType        of Ast.meta_name mcode * pure
 205   | AsType          of typeC * typeC (* as type, always metavar *)
 206   | DisjType        of string mcode * typeC list * (* only after iso *)
 207                        string mcode list (* the |s *)  * string mcode
 208   | OptType         of typeC
 209   | UniqueType      of typeC
 210
 211 and typeC = base_typeC wrap
 212
 213 (* --------------------------------------------------------------------- *)
 214 (* Variable declaration *)
 215 (* Even if the Cocci program specifies a list of declarations, they are
 216    split out into multiple declarations of a single variable each. *)
 217
 218 and base_declaration =
 219     MetaDecl of Ast.meta_name mcode * pure (* variables *)
 220     (* the following are kept separate from MetaDecls because ultimately
 221        they don't match the same thin at all.  Consider whether there
 222        should be a separate type for fields, as in the C AST *)
 223   | MetaField of Ast.meta_name mcode * pure (* structure fields *)
 224   | MetaFieldList of Ast.meta_name mcode * listlen * pure (* structure fields *)
 225   | AsDecl        of declaration * declaration
 226   | Init of Ast.storage mcode option * typeC * ident * string mcode (*=*) *
 227         initialiser * string mcode (*;*)
 228   | UnInit of Ast.storage mcode option * typeC * ident * string mcode (* ; *)
 229   | TyDecl of typeC * string mcode (* ; *)
 230   | MacroDecl of ident (* name *) * string mcode (* ( *) *
 231         expression dots * string mcode (* ) *) * string mcode (* ; *)
 232   | MacroDeclInit of ident (* name *) * string mcode (* ( *) *
 233         expression dots * string mcode (* ) *) * string mcode (*=*) *
 234         initialiser * string mcode (* ; *)
 235   | Typedef of string mcode (* typedef *) * typeC * typeC * string mcode (*;*)
 236   | DisjDecl   of string mcode * declaration list *
 237                   string mcode list (* the |s *)  * string mcode
 238   (* Ddots is for a structure declaration *)
 239   | Ddots      of string mcode (* ... *) * declaration option (* whencode *)
 240   | OptDecl    of declaration
 241   | UniqueDecl of declaration
 242
 243 and declaration = base_declaration wrap
 244
 245 (* --------------------------------------------------------------------- *)
 246 (* Initializers *)
 247
 248 and base_initialiser =
 249     MetaInit of Ast.meta_name mcode * pure
 250   | MetaInitList of Ast.meta_name mcode * listlen * pure
 251   | AsInit of initialiser * initialiser (* as init, always metavar *)
 252   | InitExpr of expression
 253   | InitList of string mcode (*{*) * initialiser_list * string mcode (*}*) *
 254         (* true if ordered, as for array, false if unordered, as for struct *)
 255         bool
 256   | InitGccExt of
 257       designator list (* name *) * string mcode (*=*) *
 258         initialiser (* gccext: *)
 259   | InitGccName of ident (* name *) * string mcode (*:*) *
 260         initialiser
 261   | IComma of string mcode (* , *)
 262   | Idots  of string mcode (* ... *) * initialiser option (* whencode *)
 263   | OptIni    of initialiser
 264   | UniqueIni of initialiser
 265
 266 and designator =
 267     DesignatorField of string mcode (* . *) * ident
 268   | DesignatorIndex of string mcode (* [ *) * expression * string mcode (* ] *)
 269   | DesignatorRange of
 270       string mcode (* [ *) * expression * string mcode (* ... *) *
 271       expression * string mcode (* ] *)
 272
 273 and initialiser = base_initialiser wrap
 274
 275 and initialiser_list = initialiser dots
 276
 277 (* --------------------------------------------------------------------- *)
 278 (* Parameter *)
 279
 280 and base_parameterTypeDef =
 281     VoidParam     of typeC
 282   | Param         of typeC * ident option
 283   | MetaParam     of Ast.meta_name mcode * pure
 284   | MetaParamList of Ast.meta_name mcode * listlen * pure
 285   | PComma        of string mcode
 286   | Pdots         of string mcode (* ... *)
 287   | Pcircles      of string mcode (* ooo *)
 288   | OptParam      of parameterTypeDef
 289   | UniqueParam   of parameterTypeDef
 290
 291 and parameterTypeDef = base_parameterTypeDef wrap
 292
 293 and parameter_list = parameterTypeDef dots
 294
 295 (* --------------------------------------------------------------------- *)
 296 (* #define Parameters *)
 297
 298 and base_define_param =
 299     DParam        of ident
 300   | DPComma       of string mcode
 301   | DPdots        of string mcode (* ... *)
 302   | DPcircles     of string mcode (* ooo *)
 303   | OptDParam     of define_param
 304   | UniqueDParam  of define_param
 305
 306 and define_param = base_define_param wrap
 307
 308 and base_define_parameters =
 309     NoParams
 310   | DParams      of string mcode(*( *) * define_param dots * string mcode(* )*)
 311
 312 and define_parameters = base_define_parameters wrap
 313
 314 (* --------------------------------------------------------------------- *)
 315 (* Statement*)
 316
 317 and base_statement =
 318     Decl          of (info * mcodekind) (* before the decl *) * declaration
 319   | Seq           of string mcode (* { *) * statement dots *
 320                      string mcode (* } *)
 321   | ExprStatement of expression option * string mcode (*;*)
 322   | IfThen        of string mcode (* if *) * string mcode (* ( *) *
 323                      expression * string mcode (* ) *) *
 324                      statement * (info * mcodekind) (* after info *)
 325   | IfThenElse    of string mcode (* if *) * string mcode (* ( *) *
 326                      expression * string mcode (* ) *) *
 327                      statement * string mcode (* else *) * statement *
 328                      (info * mcodekind)
 329   | While         of string mcode (* while *) * string mcode (* ( *) *
 330                      expression * string mcode (* ) *) *
 331                      statement * (info * mcodekind) (* after info *)
 332   | Do            of string mcode (* do *) * statement *
 333                      string mcode (* while *) * string mcode (* ( *) *
 334                      expression * string mcode (* ) *) *
 335                      string mcode (* ; *)
 336   | For           of string mcode (* for *) * string mcode (* ( *) *
 337                      expression option * string mcode (*;*) *
 338                      expression option * string mcode (*;*) *
 339                      expression option * string mcode (* ) *) * statement *
 340                      (info * mcodekind) (* after info *)
 341   | Iterator      of ident (* name *) * string mcode (* ( *) *
 342                      expression dots * string mcode (* ) *) *
 343                      statement * (info * mcodekind) (* after info *)
 344   | Switch        of string mcode (* switch *) * string mcode (* ( *) *
 345                      expression * string mcode (* ) *) * string mcode (* { *) *
 346                      statement (*decl*) dots *
 347                      case_line dots * string mcode (* } *)
 348   | Break         of string mcode (* break *) * string mcode (* ; *)
 349   | Continue      of string mcode (* continue *) * string mcode (* ; *)
 350   | Label         of ident * string mcode (* : *)
 351   | Goto          of string mcode (* goto *) * ident * string mcode (* ; *)
 352   | Return        of string mcode (* return *) * string mcode (* ; *)
 353   | ReturnExpr    of string mcode (* return *) * expression *
 354                      string mcode (* ; *)
 355   | MetaStmt      of Ast.meta_name mcode * pure
 356   | MetaStmtList  of Ast.meta_name mcode(*only in statement lists*) * pure
 357   | AsStmt        of statement * statement (* as statement, always metavar *)
 358   | Exp           of expression  (* only in dotted statement lists *)
 359   | TopExp        of expression (* for macros body *)
 360   | Ty            of typeC (* only at top level *)
 361   | TopInit       of initialiser (* only at top level *)
 362   | Disj          of string mcode * statement dots list *
 363                      string mcode list (* the |s *)  * string mcode
 364   | Nest          of string mcode * statement dots * string mcode *
 365                      (statement dots,statement) whencode list * Ast.multi
 366   | Dots          of string mcode (* ... *) *
 367                      (statement dots,statement) whencode list
 368   | Circles       of string mcode (* ooo *) *
 369                      (statement dots,statement) whencode list
 370   | Stars         of string mcode (* *** *) *
 371                      (statement dots,statement) whencode list
 372   | FunDecl of (info * mcodekind) (* before the function decl *) *
 373         fninfo list * ident (* name *) *
 374         string mcode (* ( *) * parameter_list * string mcode (* ) *) *
 375         string mcode (* { *) * statement dots *
 376         string mcode (* } *)
 377   | Include of string mcode (* #include *) * Ast.inc_file mcode (* file *)
 378   | Undef of string mcode (* #define *) * ident (* name *)
 379   | Define of string mcode (* #define *) * ident (* name *) *
 380         define_parameters (*params*) * statement dots
 381   | OptStm   of statement
 382   | UniqueStm of statement
 383
 384 and fninfo =
 385     FStorage of Ast.storage mcode
 386   | FType of typeC
 387   | FInline of string mcode
 388   | FAttr of string mcode
 389
 390 and ('a,'b) whencode =
 391     WhenNot of 'a
 392   | WhenAlways of 'b
 393   | WhenModifier of Ast.when_modifier
 394   | WhenNotTrue of expression
 395   | WhenNotFalse of expression
 396
 397 and statement = base_statement wrap
 398
 399 and base_case_line =
 400     Default of string mcode (* default *) * string mcode (*:*) * statement dots
 401   | Case of string mcode (* case *) * expression * string mcode (*:*) *
 402         statement dots
 403   | DisjCase of string mcode * case_line list *
 404         string mcode list (* the |s *) * string mcode
 405   | OptCase of case_line
 406
 407 and case_line = base_case_line wrap
 408
 409 (* --------------------------------------------------------------------- *)
 410 (* Positions *)
 411
 412 and meta_pos =
 413     MetaPos of Ast.meta_name mcode * Ast.meta_name list * Ast.meta_collect
 414
 415 (* --------------------------------------------------------------------- *)
 416 (* Top-level code *)
 417
 418 and base_top_level =
 419     NONDECL of statement
 420   | TOPCODE of statement dots
 421   | CODE of statement dots
 422   | FILEINFO of string mcode (* old file *) * string mcode (* new file *)
 423   | ERRORWORDS of expression list
 424   | OTHER of statement (* temporary, disappears after top_level.ml *)
 425
 426 and top_level = base_top_level wrap
 427 and rule = top_level list
 428
 429 and parsed_rule =
 430     CocciRule of
 431       (rule * Ast.metavar list *
 432          (string list * string list * Ast.dependency * string * Ast.exists)) *
 433         (rule * Ast.metavar list) * Ast.ruletype
 434   | ScriptRule of string (* name *) *
 435       string * Ast.dependency *
 436         (Ast.script_meta_name * Ast.meta_name * Ast.metavar) list *
 437         Ast.meta_name list (*script vars*) *
 438         string
 439   | InitialScriptRule of  string (* name *) *string * Ast.dependency * string
 440   | FinalScriptRule of  string (* name *) *string * Ast.dependency * string
 441
 442 (* --------------------------------------------------------------------- *)
 443
 444 and dependency =
 445     Dep of string (* rule applies for the current binding *)
 446   | AntiDep of dependency (* rule doesn't apply for the current binding *)
 447   | EverDep of string (* rule applies for some binding *)
 448   | NeverDep of string (* rule never applies for any binding *)
 449   | AndDep of dependency * dependency
 450   | OrDep of dependency * dependency
 451   | NoDep | FailDep
 452
 453 (* --------------------------------------------------------------------- *)
 454
 455 and anything =
 456     DotsExprTag of expression dots
 457   | DotsInitTag of initialiser dots
 458   | DotsParamTag of parameterTypeDef dots
 459   | DotsStmtTag of statement dots
 460   | DotsDeclTag of declaration dots
 461   | DotsCaseTag of case_line dots
 462   | IdentTag of ident
 463   | ExprTag of expression
 464   | ArgExprTag of expression  (* for isos *)
 465   | TestExprTag of expression (* for isos *)
 466   | TypeCTag of typeC
 467   | ParamTag of parameterTypeDef
 468   | InitTag of initialiser
 469   | DeclTag of declaration
 470   | StmtTag of statement
 471   | CaseLineTag of case_line
 472   | TopTag of top_level
 473   | IsoWhenTag of Ast.when_modifier
 474   | IsoWhenTTag of expression
 475   | IsoWhenFTag of expression
 476   | MetaPosTag of meta_pos
 477   | HiddenVarTag of anything list (* in iso_compile/pattern only *)
 478
 479 let dotsExpr x = DotsExprTag x
 480 let dotsParam x = DotsParamTag x
 481 let dotsInit x = DotsInitTag x
 482 let dotsStmt x = DotsStmtTag x
 483 let dotsDecl x = DotsDeclTag x
 484 let dotsCase x = DotsCaseTag x
 485 let ident x = IdentTag x
 486 let expr x = ExprTag x
 487 let typeC x = TypeCTag x
 488 let param x = ParamTag x
 489 let ini x = InitTag x
 490 let decl x = DeclTag x
 491 let stmt x = StmtTag x
 492 let case_line x = CaseLineTag x
 493 let top x = TopTag x
 494
 495 (* --------------------------------------------------------------------- *)
 496 (* Avoid cluttering the parser.  Calculated in compute_lines.ml. *)
 497
 498 let pos_info =
 499   { line_start = -1; line_end = -1;
 500     logical_start = -1; logical_end = -1;
 501     column = -1; offset = -1; }
 502
 503 let default_info _ = (* why is this a function? *)
 504   { pos_info = pos_info;
 505     attachable_start = true; attachable_end = true;
 506     mcode_start = []; mcode_end = [];
 507     strings_before = []; strings_after = []; isSymbolIdent = false; }
 508
 509 let default_befaft _ =
 510   MIXED(ref (Ast.NOTHING,default_token_info,default_token_info))
 511 let context_befaft _ =
 512   CONTEXT(ref (Ast.NOTHING,default_token_info,default_token_info))
 513           let minus_befaft _ = MINUS(ref (Ast.NOREPLACEMENT,default_token_info))
 514
 515 let wrap x =
 516   { node = x;
 517     info = default_info();
 518     index = ref (-1);
 519     mcodekind = ref (default_befaft());
 520     exp_ty = ref None;
 521     bef_aft = NoDots;
 522     true_if_arg = false;
 523     true_if_test = false;
 524     true_if_test_exp = false;
 525     iso_info = [] }
 526 let context_wrap x =
 527   { node = x;
 528     info = default_info();
 529     index = ref (-1);
 530     mcodekind = ref (context_befaft());
 531     exp_ty = ref None;
 532     bef_aft = NoDots;
 533     true_if_arg = false;
 534     true_if_test = false;
 535     true_if_test_exp = false;
 536     iso_info = [] }
 537 let unwrap x = x.node
 538 let unwrap_mcode (x,_,_,_,_,_) = x
 539 let rewrap model x = { model with node = x }
 540 let rewrap_mcode (_,arity,info,mcodekind,pos,adj) x =
 541   (x,arity,info,mcodekind,pos,adj)
 542 let copywrap model x =
 543   { model with node = x; index = ref !(model.index);
 544     mcodekind = ref !(model.mcodekind); exp_ty = ref !(model.exp_ty)}
 545 let get_pos (_,_,_,_,x,_) = !x
 546 let get_pos_ref (_,_,_,_,x,_) = x
 547 let set_pos pos (m,arity,info,mcodekind,_,adj) =
 548   (m,arity,info,mcodekind,ref pos,adj)
 549 let get_info x      = x.info
 550 let set_info x info = {x with info = info}
 551 let get_line x      = x.info.pos_info.line_start
 552 let get_line_end x  = x.info.pos_info.line_end
 553 let get_index x     = !(x.index)
 554 let set_index x i   = x.index := i
 555 let get_mcodekind x = !(x.mcodekind)
 556 let get_mcode_mcodekind (_,_,_,mcodekind,_,_) = mcodekind
 557 let get_mcodekind_ref x = x.mcodekind
 558 let set_mcodekind x mk  = x.mcodekind := mk
 559 let set_type x t        = x.exp_ty := t
 560 let get_type x          = !(x.exp_ty)
 561 let get_dots_bef_aft x  = x.bef_aft
 562 let set_dots_bef_aft x dots_bef_aft = {x with bef_aft = dots_bef_aft}
 563 let get_arg_exp x       = x.true_if_arg
 564 let set_arg_exp x       = {x with true_if_arg = true}
 565 let get_test_pos x      = x.true_if_test
 566 let set_test_pos x      = {x with true_if_test = true}
 567 let get_test_exp x      = x.true_if_test_exp
 568 let set_test_exp x      = {x with true_if_test_exp = true}
 569 let get_iso x           = x.iso_info
 570 let set_iso x i = if !Flag.track_iso_usage then {x with iso_info = i} else x
 571 let set_mcode_data data (_,ar,info,mc,pos,adj) = (data,ar,info,mc,pos,adj)
 572
 573 (* --------------------------------------------------------------------- *)
 574
 575 let rec meta_pos_name = function
 576     HiddenVarTag(vars) ->
 577         (* totally fake, just drop the rest, only for isos *)
 578       meta_pos_name (List.hd vars)
 579   | MetaPosTag(MetaPos(name,constraints,_)) -> name
 580   | ExprTag(e) ->
 581       (match unwrap e with
 582         MetaExpr(name,constraints,ty,form,pure) -> name
 583       | _ -> failwith "bad metavariable")
 584   | TypeCTag(t) ->
 585       (match unwrap t with
 586         MetaType(name,pure) -> name
 587       | _ -> failwith "bad metavariable")
 588   | DeclTag(d) ->
 589       (match unwrap d with
 590         MetaDecl(name,pure) -> name
 591       | _ -> failwith "bad metavariable")
 592   | InitTag(i) ->
 593       (match unwrap i with
 594         MetaInit(name,pure) -> name
 595       | _ -> failwith "bad metavariable")
 596   | StmtTag(s) ->
 597       (match unwrap s with
 598         MetaStmt(name,pure) -> name
 599       | _ -> failwith "bad metavariable")
 600   | _ -> failwith "bad metavariable"
 601
 602 (* --------------------------------------------------------------------- *)
 603
 604 (* unique indices, for mcode and tree nodes *)
 605 let index_counter = ref 0
 606 let fresh_index _ = let cur = !index_counter in index_counter := cur + 1; cur
 607
 608 (* --------------------------------------------------------------------- *)
 609
 610 let undots d =
 611   match unwrap d with
 612   | DOTS    e -> e
 613   | CIRCLES e -> e
 614   | STARS   e -> e
 615
 616 (* --------------------------------------------------------------------- *)
 617
 618 let rec ast0_type_to_type ty =
 619   match unwrap ty with
 620     ConstVol(cv,ty) -> TC.ConstVol(const_vol cv,ast0_type_to_type ty)
 621   | BaseType(bty,strings) ->
 622       TC.BaseType(baseType bty)
 623   | Signed(sgn,None) ->
 624       TC.SignedT(sign sgn,None)
 625   | Signed(sgn,Some ty) ->
 626       let bty = ast0_type_to_type ty in
 627       TC.SignedT(sign sgn,Some bty)
 628   | Pointer(ty,_) -> TC.Pointer(ast0_type_to_type ty)
 629   | FunctionPointer(ty,_,_,_,_,params,_) ->
 630       TC.FunctionPointer(ast0_type_to_type ty)
 631   | FunctionType _ -> TC.Unknown (*failwith "not supported"*)
 632   | Array(ety,_,_,_) -> TC.Array(ast0_type_to_type ety)
 633   | EnumName(su,Some tag) ->
 634       (match unwrap tag with
 635         Id(tag) ->
 636           TC.EnumName(TC.Name(unwrap_mcode tag))
 637       | MetaId(tag,_,_,_) ->
 638           (Common.pr2_once
 639              "warning: enum with a metavariable name detected.";
 640            Common.pr2_once
 641              "For type checking assuming the name of the metavariable is the name of the type\n";
 642            TC.EnumName(TC.MV(unwrap_mcode tag,TC.Unitary,false)))
 643       | _ -> failwith "unexpected enum type name")
 644   | EnumName(su,None) -> TC.EnumName TC.NoName
 645   | EnumDef(ty,_,_,_) -> ast0_type_to_type ty
 646   | StructUnionName(su,Some tag) ->
 647       (match unwrap tag with
 648         Id(tag) ->
 649           TC.StructUnionName(structUnion su,TC.Name(unwrap_mcode tag))
 650       | MetaId(tag,Ast.IdNoConstraint,_,_) ->
 651           (Common.pr2_once
 652              "warning: struct/union with a metavariable name detected.";
 653            Common.pr2_once
 654              "For type checking assuming the name of the metavariable is the name of the type\n";
 655            TC.StructUnionName(structUnion su,
 656                               TC.MV(unwrap_mcode tag,TC.Unitary,false)))
 657       | MetaId(tag,_,_,_) ->
 658           (* would have to duplicate the type in type_cocci.ml?
 659              perhaps polymorphism would help? *)
 660           failwith "constraints not supported on struct type name"
 661       | _ -> failwith "unexpected struct/union type name")
 662   | StructUnionName(su,None) -> TC.StructUnionName(structUnion su,TC.NoName)
 663   | StructUnionDef(ty,_,_,_) -> ast0_type_to_type ty
 664   | TypeName(name) -> TC.TypeName(unwrap_mcode name)
 665   | MetaType(name,_) ->
 666       TC.MetaType(unwrap_mcode name,TC.Unitary,false)
 667   | AsType(ty,asty) -> failwith "not created yet"
 668   | DisjType(_,types,_,_) ->
 669       Common.pr2_once
 670         "disjtype not supported in smpl type inference, assuming unknown";
 671       TC.Unknown
 672   | OptType(ty) | UniqueType(ty) ->
 673       ast0_type_to_type ty
 674
 675 and baseType = function
 676     Ast.VoidType -> TC.VoidType
 677   | Ast.CharType -> TC.CharType
 678   | Ast.ShortType -> TC.ShortType
 679   | Ast.ShortIntType -> TC.ShortIntType
 680   | Ast.IntType -> TC.IntType
 681   | Ast.DoubleType -> TC.DoubleType
 682   | Ast.LongDoubleType -> TC.LongDoubleType
 683   | Ast.FloatType -> TC.FloatType
 684   | Ast.LongType -> TC.LongType
 685   | Ast.LongIntType -> TC.LongIntType
 686   | Ast.LongLongType -> TC.LongLongType
 687   | Ast.LongLongIntType -> TC.LongLongIntType
 688   | Ast.SizeType -> TC.SizeType
 689   | Ast.SSizeType -> TC.SSizeType
 690   | Ast.PtrDiffType -> TC.PtrDiffType
 691
 692 and structUnion t =
 693   match unwrap_mcode t with
 694     Ast.Struct -> TC.Struct
 695   | Ast.Union -> TC.Union
 696
 697 and sign t =
 698   match unwrap_mcode t with
 699     Ast.Signed -> TC.Signed
 700   | Ast.Unsigned -> TC.Unsigned
 701
 702 and const_vol t =
 703   match unwrap_mcode t with
 704     Ast.Const -> TC.Const
 705   | Ast.Volatile -> TC.Volatile
 706
 707 (* --------------------------------------------------------------------- *)
 708 (* this function is a rather minimal attempt.  the problem is that information
 709 has been lost.  but since it is only used for metavariable types in the isos,
 710 perhaps it doesn't matter *)
 711 and make_mcode x = (x,NONE,default_info(),context_befaft(),ref [],-1)
 712 let make_mcode_info x info = (x,NONE,info,context_befaft(),ref [],-1)
 713 and make_minus_mcode x =
 714   (x,NONE,default_info(),minus_befaft(),ref [],-1)
 715
 716 exception TyConv
 717
 718 let rec reverse_type ty =
 719   match ty with
 720     TC.ConstVol(cv,ty) ->
 721       ConstVol(reverse_const_vol cv,context_wrap(reverse_type ty))
 722   | TC.BaseType(bty) ->
 723       BaseType(reverse_baseType bty,[(* not used *)])
 724   | TC.SignedT(sgn,None) -> Signed(reverse_sign sgn,None)
 725   | TC.SignedT(sgn,Some bty) ->
 726       Signed(reverse_sign sgn,Some (context_wrap(reverse_type ty)))
 727   | TC.Pointer(ty) ->
 728       Pointer(context_wrap(reverse_type ty),make_mcode "*")
 729   | TC.EnumName(TC.MV(name,_,_)) ->
 730       EnumName
 731         (make_mcode "enum",
 732          Some (context_wrap(MetaId(make_mcode name,Ast.IdNoConstraint,Ast.NoVal,
 733                                    Impure))))
 734   | TC.EnumName(TC.Name tag) ->
 735       EnumName(make_mcode "enum",Some(context_wrap(Id(make_mcode tag))))
 736   | TC.StructUnionName(su,TC.MV(name,_,_)) ->
 737       (* not right?... *)
 738       StructUnionName
 739         (reverse_structUnion su,
 740          Some(context_wrap(MetaId(make_mcode name,Ast.IdNoConstraint,Ast.NoVal,
 741                                   Impure(*not really right*)))))
 742   |  TC.StructUnionName(su,TC.Name tag) ->
 743       StructUnionName
 744         (reverse_structUnion su,
 745          Some (context_wrap(Id(make_mcode tag))))
 746   | TC.TypeName(name) -> TypeName(make_mcode name)
 747   | TC.MetaType(name,_,_) ->
 748       MetaType(make_mcode name,Impure(*not really right*))
 749   | _ -> raise TyConv
 750
 751 and reverse_baseType = function
 752     TC.VoidType -> Ast.VoidType
 753   | TC.CharType -> Ast.CharType
 754   | TC.BoolType -> Ast.IntType
 755   | TC.ShortType -> Ast.ShortType
 756   | TC.ShortIntType -> Ast.ShortIntType
 757   | TC.IntType -> Ast.IntType
 758   | TC.DoubleType -> Ast.DoubleType
 759   | TC.LongDoubleType -> Ast.LongDoubleType
 760   | TC.FloatType -> Ast.FloatType
 761   | TC.LongType -> Ast.LongType
 762   | TC.LongIntType -> Ast.LongIntType
 763   | TC.LongLongType -> Ast.LongLongType
 764   | TC.LongLongIntType -> Ast.LongLongIntType
 765   | TC.SizeType -> Ast.SizeType
 766   | TC.SSizeType -> Ast.SSizeType
 767   | TC.PtrDiffType -> Ast.PtrDiffType
 768
 769
 770 and reverse_structUnion t =
 771   make_mcode
 772     (match t with
 773       TC.Struct -> Ast.Struct
 774     | TC.Union -> Ast.Union)
 775
 776 and reverse_sign t =
 777   make_mcode
 778     (match t with
 779       TC.Signed -> Ast.Signed
 780     | TC.Unsigned -> Ast.Unsigned)
 781
 782 and reverse_const_vol t =
 783   make_mcode
 784     (match t with
 785       TC.Const -> Ast.Const
 786     | TC.Volatile -> Ast.Volatile)
 787
 788 (* --------------------------------------------------------------------- *)
 789
 790 let lub_pure x y =
 791   match (x,y) with
 792     (Impure,_) | (_,Impure) -> Impure
 793   | (Pure,Context) | (Context,Pure) -> Impure
 794   | (Pure,_) | (_,Pure) -> Pure
 795   | (_,Context) | (Context,_) -> Context
 796   | _ -> PureContext
 797
 798 (* --------------------------------------------------------------------- *)
 799
 800 let rule_name = ref "" (* for the convenience of the parser *)