parsing_cocci/ast0_cocci.ml

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