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