engine/c_vs_c.ml

   1 (*
   2 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
   3 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
   4 * This file is part of Coccinelle.
   5 *
   6 * Coccinelle is free software: you can redistribute it and/or modify
   7 * it under the terms of the GNU General Public License as published by
   8 * the Free Software Foundation, according to version 2 of the License.
   9 *
  10 * Coccinelle is distributed in the hope that it will be useful,
  11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 * GNU General Public License for more details.
  14 *
  15 * You should have received a copy of the GNU General Public License
  16 * along with Coccinelle.  If not, see <http://www.gnu.org/licenses/>.
  17 *
  18 * The authors reserve the right to distribute this or future versions of
  19 * Coccinelle under other licenses.
  20 *)
  21
  22
  23 open Common
  24
  25 open Ast_c
  26
  27 (* For the moment I do only eq_type and not eq_expr, etc. The reason
  28  * for eq_type is related to the typedef and struct isomorphism. Sometimes
  29  * one use the typedef and sometimes the structname.
  30  *
  31  * TODO: should use the isomorphisms engine of julia.
  32  * Maybe I can transform my ast_c in ast_cocci, and use julia's code ?
  33  * Maybe I can add some Disj in my ast_c ?
  34  *)
  35
  36
  37 module type PARAM =
  38   sig
  39     type tin
  40     type 'x tout
  41
  42     type 'a matcher = 'a -> 'a  -> tin -> 'a tout
  43
  44     val (>>=):
  45       (tin -> 'a tout)  ->
  46       ('a -> (tin -> 'b tout)) ->
  47       (tin -> 'b tout)
  48
  49     val (>&&>) : bool -> (tin -> 'x tout) -> (tin -> 'x tout)
  50
  51     val return : 'a -> tin -> 'a tout
  52     val fail : tin -> 'a tout
  53 end
  54
  55
  56 module C_VS_C =
  57   functor (X : PARAM) ->
  58 struct
  59
  60 type 'a matcher = 'a -> 'a  -> X.tin -> 'a X.tout
  61
  62 let (>>=) = X.(>>=)
  63 let (>&&>) = X.(>&&>)
  64 let return = X.return
  65 let fail = X.fail
  66
  67 let (option: 'a matcher -> ('a option matcher)) = fun f t1 t2 ->
  68   match (t1,t2) with
  69   | (Some t1, Some t2) ->
  70       f t1 t2 >>= (fun t ->
  71         return (Some t)
  72       )
  73   | (None, None) -> return None
  74   | _ -> fail
  75
  76
  77 let same_s saopt sbopt =
  78   match saopt, sbopt with
  79   | None, None -> true
  80   | Some namea, Some nameb ->
  81       let sa = Ast_c.str_of_name namea in
  82       let sb = Ast_c.str_of_name nameb in
  83       sa =$= sb
  84   | _ -> false
  85
  86
  87 let rec fullType a b =
  88   let ((qua,iiqa), tya) = a in
  89   let ((qub,iiqb), tyb) = b in
  90   (qua.const =:= qub.const && qua.volatile =:= qub.volatile) >&&>
  91
  92     let (qu,iiq) = (qua, iiqa) in
  93     typeC tya tyb >>= (fun ty ->
  94       return ((qu,iiq), ty)
  95     )
  96
  97 and typeC tya tyb =
  98   let (a, iia) = tya in
  99   let (b, iib) = tyb in
 100
 101   let iix = iia in
 102
 103   match a, b with
 104   | BaseType a, BaseType b ->
 105       a =*= b >&&> return (BaseType a, iix)
 106   | Pointer a, Pointer b ->
 107       fullType a b >>= (fun x -> return (Pointer x, iix))
 108
 109   | StructUnionName (sua, sa), StructUnionName (sub, sb) ->
 110       (sua =*= sub && sa =$= sb) >&&>
 111         return (StructUnionName (sua, sa), iix)
 112
 113   | TypeName (namea, opta), TypeName (nameb, optb) ->
 114       let sa = Ast_c.str_of_name namea in
 115       let sb = Ast_c.str_of_name nameb in
 116
 117       (* assert compatible opta optb ? *)
 118       (*option fullType opta optb*)
 119       sa =$= sb >&&>
 120        let opt =
 121          (match opta, optb with
 122          | None, None -> None
 123
 124          | Some x, _
 125          | _, Some x
 126
 127              -> Some x
 128          )
 129        in
 130        return (TypeName (namea, opt), iix)
 131
 132
 133   | Array (ea, a), Array (eb,b) ->
 134       let get_option f = function Some x -> Some (f x) | None -> None in
 135       let ea = get_option Lib_parsing_c.al_expr ea in
 136       let eb = get_option Lib_parsing_c.al_expr eb in
 137       ea =*= eb >&&> fullType a b >>= (fun x -> return (Array (ea, x), iix))
 138
 139   | FunctionType (returna, paramsa), FunctionType (returnb, paramsb) ->
 140       let (tsa, (ba,iihas3dotsa)) = paramsa in
 141       let (tsb, (bb,iihas3dotsb)) = paramsb in
 142
 143       let bx = ba in
 144       let iihas3dotsx = iihas3dotsa in
 145
 146       (ba =:= bb && List.length tsa =|= List.length tsb) >&&>
 147       fullType returna returnb >>= (fun returnx ->
 148
 149       Common.zip tsa tsb +> List.fold_left
 150         (fun acc ((parama,iia),(paramb,iib))->
 151           let iix = iia in
 152           acc >>= (fun xs ->
 153
 154             let {p_register = (ba,iiba); p_namei = saopt; p_type = ta} =
 155               parama in
 156             let {p_register = (bb,iibb); p_namei = sbopt; p_type = tb} =
 157               paramb in
 158
 159             let bx = ba in
 160             let iibx = iiba in
 161
 162             let sxopt = saopt in
 163
 164
 165             (* todo?  iso on name or argument ? *)
 166             (ba =:= bb && same_s saopt sbopt) >&&>
 167             fullType ta tb >>= (fun tx ->
 168               let paramx = { p_register = (bx, iibx);
 169                              p_namei = sxopt;
 170                              p_type = tx; } in
 171               return ((paramx,iix)::xs)
 172             )
 173           )
 174         ) (return [])
 175       >>= (fun tsx ->
 176         let paramsx = (List.rev tsx, (bx, iihas3dotsx)) in
 177         return (FunctionType (returnx, paramsx), iix)
 178       ))
 179
 180   | Enum (saopt, enuma), Enum (sbopt, enumb) ->
 181       (saopt =*= sbopt &&
 182       List.length enuma =|= List.length enumb &&
 183       Common.zip enuma enumb +> List.for_all (fun
 184         (((namesa,eopta), iicommaa), ((namesb,eoptb),iicommab))
 185           ->
 186             let sa = str_of_name namesa in
 187             let sb = str_of_name namesb in
 188             sa =$= sb &&
 189             (* todo ? eopta and b can have some info so ok to use =*= ?  *)
 190             eopta =*= eoptb
 191         )
 192       ) >&&>
 193         return (Enum (saopt, enuma), iix)
 194
 195   | EnumName sa, EnumName sb -> sa =$= sb >&&> return (EnumName sa, iix)
 196
 197   | ParenType a, ParenType b ->
 198       (* iso here ? *)
 199       fullType a b >>= (fun x ->
 200         return (ParenType x, iix)
 201       )
 202
 203   | TypeOfExpr ea, TypeOfExpr eb ->
 204       let ea = Lib_parsing_c.al_expr ea in
 205       let eb = Lib_parsing_c.al_expr eb in
 206       ea =*= eb >&&> return (TypeOfExpr ea, iix)
 207
 208   | TypeOfType a, TypeOfType b ->
 209       fullType a b >>= (fun x -> return (TypeOfType x, iix))
 210
 211 (*  | TypeOfType a, b ->
 212     | a, TypeOfType b ->
 213 *)
 214
 215
 216   | StructUnion (sua, saopt, sta), StructUnion (sub, sbopt, stb) ->
 217       (sua =*= sub && saopt =*= sbopt && List.length sta =|= List.length stb)
 218       >&&>
 219       Common.zip sta stb +> List.fold_left
 220         (fun acc ((fielda), (fieldb)) ->
 221           acc >>= (fun xs ->
 222             match fielda, fieldb with
 223             | EmptyField iia, EmptyField iib ->
 224                 let iix = iia in
 225                 return ((EmptyField iix)::xs)
 226
 227             | DeclarationField (FieldDeclList (fa, iipta)),
 228               DeclarationField (FieldDeclList (fb, iiptb)) ->
 229                 let iipt = iipta in (* TODO ?*)
 230                 (List.length fa =|= List.length fb) >&&>
 231
 232                 Common.zip fa fb +> List.fold_left
 233                   (fun acc2 ((fielda,iia),(fieldb,iib))->
 234                     let iix = iia in
 235                     acc2 >>= (fun xs ->
 236                       match fielda, fieldb with
 237                       | Simple (nameaopt, ta), Simple (namebopt, tb) ->
 238
 239
 240                           same_s nameaopt namebopt >&&>
 241                           fullType ta tb >>= (fun tx ->
 242                             return (((Simple (nameaopt, tx)), iix)::xs)
 243                           )
 244
 245                       | BitField (nameopta, ta, infoa, ea),
 246                         BitField (nameoptb, tb, infob, eb) ->
 247                           let infox = infoa in
 248                           (same_s nameopta nameoptb && ea =*= eb) >&&>
 249                           fullType ta tb >>= (fun tx ->
 250                             return (((BitField (nameopta,tx,infox,ea)), iix)::xs)
 251                           )
 252                       | _,_ -> fail
 253                     )
 254                   ) (return [])
 255                  >>= (fun fx ->
 256                    return (((DeclarationField
 257                                (FieldDeclList (List.rev fx,iipt))))::xs)
 258                  )
 259             | _ -> fail
 260           )
 261
 262
 263         ) (return [])
 264         >>= (fun stx ->
 265           return (StructUnion (sua, saopt, List.rev stx), iix)
 266         )
 267
 268
 269
 270   (* choose the lub.
 271    * subtil: in the return must put iia, not iix, and in following case
 272    * must put iib and not iix, because we want the token corresponding
 273    * to the typedef.
 274    *)
 275   | TypeName (name, Some a), _ ->
 276       fullType a (Ast_c.nQ, tyb) >>= (fun x ->
 277         return (TypeName (name, Some x), iia)
 278       )
 279
 280   | _, TypeName (name, Some b) ->
 281       fullType b (Ast_c.nQ, tya) >>= (fun x ->
 282         return (TypeName (name, Some x), iib) (* subtil: *)
 283       )
 284
 285   | _, _ -> fail
 286
 287
 288
 289 end
 290
 291 module XEQ = struct
 292   type tin = unit
 293   type 'a tout = 'a option
 294
 295   type 'a matcher = 'a -> 'a -> tin -> 'a tout
 296
 297   let return x = fun tin -> Some x
 298   let fail = fun tin -> None
 299
 300   let (>>=) m f = fun tin ->
 301     match m tin with
 302     | None -> None
 303     | Some x -> f x tin
 304
 305   let (>&&>) b m = fun tin ->
 306     if b then m tin
 307     else fail tin
 308
 309 end
 310
 311 module EQ = C_VS_C (XEQ)
 312
 313
 314 let eq_type2 a b = EQ.fullType a b () <> None
 315 let merge_type2 a b = Common.some (EQ.fullType a b ())
 316
 317 let eq_type a b =
 318   Common.profile_code "C_vs_c" (fun () -> eq_type2 a b)
 319
 320 let merge_type a b =
 321   Common.profile_code "C_vs_c" (fun () -> merge_type2 a b)