engine/.#c_vs_c.ml.1.9

   1 (*
   2 * Copyright 2005-2008, 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 rec fullType a b =
  78   let ((qua,iiqa), tya) = a in
  79   let ((qub,iiqb), tyb) = b in
  80   (qua.const =:= qub.const && qua.volatile =:= qub.volatile) >&&>
  81
  82     let (qu,iiq) = (qua, iiqa) in
  83     typeC tya tyb >>= (fun ty ->
  84       return ((qu,iiq), ty)
  85     )
  86
  87 and typeC tya tyb =
  88   let (a, iia) = tya in
  89   let (b, iib) = tyb in
  90
  91   let iix = iia in
  92
  93   match a, b with
  94   | BaseType a, BaseType b ->
  95       a =*= b >&&> return (BaseType a, iix)
  96   | Pointer a, Pointer b ->
  97       fullType a b >>= (fun x -> return (Pointer x, iix))
  98
  99   | StructUnionName (sua, sa), StructUnionName (sub, sb) ->
 100       (sua =*= sub && sa =$= sb) >&&>
 101         return (StructUnionName (sua, sa), iix)
 102
 103   | TypeName (sa, opta), TypeName (sb, optb) ->
 104       (* assert compatible opta optb ? *)
 105       (*option fullType opta optb*)
 106       sa =$= sb >&&>
 107        let opt =
 108          (match opta, optb with
 109          | None, None -> None
 110          | Some x, _
 111          | _, Some x
 112              -> Some x
 113          )
 114        in
 115        return (TypeName (sa, opt), iix)
 116
 117
 118   | Array (ea, a), Array (eb,b) ->
 119       let get_option f = function Some x -> Some (f x) | None -> None in
 120       let ea = get_option Lib_parsing_c.al_expr ea in
 121       let eb = get_option Lib_parsing_c.al_expr eb in
 122       ea =*= eb >&&> fullType a b >>= (fun x -> return (Array (ea, x), iix))
 123
 124   | FunctionType (returna, paramsa), FunctionType (returnb, paramsb) ->
 125       let (tsa, (ba,iihas3dotsa)) = paramsa in
 126       let (tsb, (bb,iihas3dotsb)) = paramsb in
 127
 128       let bx = ba in
 129       let iihas3dotsx = iihas3dotsa in
 130
 131       (ba = bb && List.length tsa = List.length tsb) >&&>
 132       fullType returna returnb >>= (fun returnx ->
 133
 134       Common.zip tsa tsb +> List.fold_left
 135         (fun acc ((parama,iia),(paramb,iib))->
 136           let iix = iia in
 137           acc >>= (fun xs ->
 138
 139             let (((ba, saopt, ta), ii_b_sa)) = parama in
 140             let (((bb, sbopt, tb), ii_b_sb)) = paramb in
 141
 142             let bx = ba in
 143             let sxopt = saopt in
 144             let ii_b_sx = ii_b_sa in
 145
 146             (ba =:= bb && saopt =*= sbopt) >&&>
 147             fullType ta tb >>= (fun tx ->
 148               let paramx = (((bx, sxopt, tx), ii_b_sx)) 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         ((((sa, eopta),ii_s_eqa), iicommaa), (((sb, eoptb),ii_s_eqb),iicommab))
 163           ->
 164             sa =$= sb &&
 165             eopta =*= eoptb
 166         )
 167       ) >&&>
 168         return (Enum (saopt, enuma), iix)
 169
 170   | EnumName sa, EnumName sb -> sa =$= sb >&&> return (EnumName sa, iix)
 171
 172   | ParenType a, ParenType b ->
 173       (* iso here ? *)
 174       fullType a b >>= (fun x ->
 175         return (ParenType x, iix)
 176       )
 177
 178   | TypeOfExpr ea, TypeOfExpr eb ->
 179       let ea = Lib_parsing_c.al_expr ea in
 180       let eb = Lib_parsing_c.al_expr eb in
 181       ea =*= eb >&&> return (TypeOfExpr ea, iix)
 182
 183   | TypeOfType a, TypeOfType b ->
 184       fullType a b >>= (fun x -> return (TypeOfType x, iix))
 185
 186 (*  | TypeOfType a, b ->
 187     | a, TypeOfType b ->
 188 *)
 189
 190
 191   | StructUnion (sua, saopt, sta), StructUnion (sub, sbopt, stb) ->
 192       (sua =*= sub && saopt =*= sbopt && List.length sta = List.length stb)
 193       >&&>
 194       Common.zip sta stb +> List.fold_left
 195         (fun acc ((xfielda, iia), (xfieldb, iib)) ->
 196           let iix = iia in
 197           acc >>= (fun xs ->
 198             match xfielda, xfieldb with
 199             | EmptyField, EmptyField -> return ((EmptyField, iix)::xs)
 200
 201             | DeclarationField (FieldDeclList (fa, iipta)),
 202               DeclarationField (FieldDeclList (fb, iiptb)) ->
 203                 let iipt = iipta in (* TODO ?*)
 204                 (List.length fa =|= List.length fb) >&&>
 205
 206                 Common.zip fa fb +> List.fold_left
 207                   (fun acc2 ((fielda,iia),(fieldb,iib))->
 208                     let iix = iia in
 209                     acc2 >>= (fun xs ->
 210                       let (fa, ii2a) = fielda in
 211                       let (fb, ii2b) = fieldb in
 212                       let ii2x = ii2a in
 213                       match fa, fb with
 214                       | Simple (saopt, ta), Simple (sbopt, tb) ->
 215                           saopt =*= sbopt >&&>
 216                           fullType ta tb >>= (fun tx ->
 217                             return (((Simple (saopt, tx), ii2x), iix)::xs)
 218                           )
 219
 220                       | BitField (sopta, ta, ea), BitField (soptb, tb, eb) ->
 221                           (sopta =*= soptb && ea =*= eb) >&&>
 222                           fullType ta tb >>= (fun tx ->
 223                             return (((BitField (sopta,tx,ea), ii2x), iix)::xs)
 224                           )
 225                       | _,_ -> fail
 226                     )
 227                   ) (return [])
 228                  >>= (fun fx ->
 229                    return (((DeclarationField
 230                                (FieldDeclList (List.rev fx,iipt))), iix)::xs)
 231                  )
 232             | _ -> fail
 233           )
 234
 235
 236         ) (return [])
 237         >>= (fun stx ->
 238           return (StructUnion (sua, saopt, List.rev stx), iix)
 239         )
 240
 241
 242
 243   (* choose the lub.
 244    * subtil: in the return must put iia, not iix, and in following case
 245    * must put iib and not iix, because we want the token corresponding
 246    * to the typedef.
 247    *)
 248   | TypeName (s, Some a), _ ->
 249       fullType a (Ast_c.nQ, tyb) >>= (fun x ->
 250         return (TypeName (s, Some x), iia)
 251       )
 252
 253   | _, TypeName (s, Some b) ->
 254       fullType b (Ast_c.nQ, tya) >>= (fun x ->
 255         return (TypeName (s, Some x), iib) (* subtil: *)
 256       )
 257
 258   | _, _ -> fail
 259
 260
 261
 262 end
 263
 264 module XEQ = struct
 265   type tin = unit
 266   type 'a tout = 'a option
 267
 268   type 'a matcher = 'a -> 'a -> tin -> 'a tout
 269
 270   let return x = fun tin -> Some x
 271   let fail = fun tin -> None
 272
 273   let (>>=) m f = fun tin ->
 274     match m tin with
 275     | None -> None
 276     | Some x -> f x tin
 277
 278   let (>&&>) b m = fun tin ->
 279     if b then m tin
 280     else fail tin
 281
 282 end
 283
 284 module EQ = C_VS_C (XEQ)
 285
 286
 287 let eq_type2 a b = EQ.fullType a b () <> None
 288 let merge_type2 a b = Common.some (EQ.fullType a b ())
 289
 290 let eq_type a b =
 291   Common.profile_code "C_vs_c" (fun () -> eq_type2 a b)
 292
 293 let merge_type a b =
 294   Common.profile_code "C_vs_c" (fun () -> merge_type2 a b)