engine/c_vs_c.ml

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