parsing_cocci/type_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 (* for metavariables in general, but here because needed for metatypes *)
  28 type inherited = bool (* true if inherited *)
  29 type keep_binding = Unitary (* need no info *)
  30   | Nonunitary (* need an env entry *) | Saved (* need a witness *)
  31
  32 type meta_name = string * string (*Ast_cocci.meta_name*)
  33
  34 type typeC =
  35     ConstVol        of const_vol * typeC
  36   | BaseType        of baseType
  37   | SignedT         of sign * typeC option
  38   | Pointer         of typeC
  39   | FunctionPointer of typeC (* only return type *)
  40   | Array           of typeC (* drop size info *)
  41   | EnumName        of name
  42   | StructUnionName of structUnion * name
  43   | TypeName        of string
  44   | MetaType        of meta_name * keep_binding * inherited
  45   | Unknown (* for metavariables of type expression *^* *)
  46
  47 and name =
  48     NoName
  49   | Name of string
  50   | MV of meta_name * keep_binding * inherited
  51
  52 and tagged_string = string
  53
  54 and baseType = VoidType | CharType | ShortType | ShortIntType | IntType
  55 | DoubleType | LongDoubleType | FloatType
  56 | LongType | LongIntType | LongLongType | LongLongIntType
  57 | SizeType | SSizeType | PtrDiffType | BoolType
  58
  59 and structUnion = Struct | Union
  60
  61 and sign = Signed | Unsigned
  62
  63 and const_vol = Const | Volatile
  64
  65 (* --------------------------------------------------------------------- *)
  66 (* Printer *)
  67 open Format
  68
  69 let rec type2c = function
  70     ConstVol(cv,ty) -> (const_vol cv) ^ (type2c ty)
  71   | BaseType(ty) -> baseType ty
  72   | SignedT(sgn,None) -> sign sgn
  73   | SignedT(sgn,Some ty) -> (sign sgn) ^ (type2c ty)
  74   | Pointer(ty) -> (type2c ty) ^ "*"
  75   | FunctionPointer(ty) -> (type2c ty) ^ "(*)(...)"
  76   | Array(ty) -> (type2c ty) ^ "[] "
  77   | EnumName(name) -> "enum " ^ (print_name name)
  78   | StructUnionName(kind,name) -> (structUnion kind) ^ (print_name name)
  79   | TypeName(name) -> name ^ " "
  80   | MetaType((rule,name),keep,inherited) -> name ^ " "
  81       (*
  82       let print_unitary = function
  83           Unitary -> print_string "unitary"
  84         | Nonunitary -> print_string "nonunitary"
  85         | Saved -> print_string "saved" in
  86       print_string "/* ";
  87       print_string "keep:"; print_unitary keep;
  88       print_string " inherited:"; print_bool inherited;
  89       print_string " */"
  90       *)
  91   | Unknown -> "unknown "
  92
  93 and print_name = function
  94     NoName -> ""
  95   | MV ((_,name),_,_) -> name ^ " "
  96   | Name name -> name ^ " "
  97
  98 and baseType = function
  99     VoidType -> "void "
 100   | CharType -> "char "
 101   | ShortType -> "short "
 102   | ShortIntType -> "short int "
 103   | IntType -> "int "
 104   | DoubleType -> "double "
 105   | LongDoubleType -> "long double "
 106   | FloatType -> "float "
 107   | LongType -> "long "
 108   | LongIntType -> "long int "
 109   | LongLongType -> "long long "
 110   | LongLongIntType -> "long long int "
 111   | BoolType -> "bool "
 112   | SizeType -> "size_t "
 113   | SSizeType -> "ssize_t "
 114   | PtrDiffType -> "ptrdiff_t "
 115
 116
 117 and structUnion = function
 118     Struct -> "struct "
 119   | Union -> "union "
 120
 121 and sign = function
 122     Signed -> "signed "
 123   | Unsigned -> "unsigned "
 124
 125 and const_vol = function
 126     Const -> "const "
 127   | Volatile -> "volatile "
 128
 129 let typeC t = print_string (type2c t)
 130
 131 (* t1 should be less informative than t1, eg t1 = Pointer(Unknown) and t2 =
 132 Pointer(int) *)
 133 (* only used in iso *)
 134 (* needs to do something for MetaType *)
 135 let compatible t1 = function
 136     None -> t1 = Unknown
 137   | Some t2 ->
 138       let rec loop = function
 139           (Unknown,_) -> true
 140         | (ConstVol(cv1,ty1),ConstVol(cv2,ty2)) when cv1 = cv2 ->
 141             loop(ty1,ty2)
 142         | (Pointer(ty1),Pointer(ty2)) -> loop(ty1,ty2)
 143         | (FunctionPointer(ty1),_) -> false (* not enough info *)
 144         | (_,FunctionPointer(ty2)) -> false (* not enough info *)
 145         | (Array(ty1),Array(ty2)) -> loop(ty1,ty2)
 146         | (_,_) -> t1=t2 in
 147       loop (t1,t2)