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