engine/c_vs_c.ml

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