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