← Back to branch summary

~npalix/coccinelle/upstream

« back to all changes in this revision

Viewing changes to engine/c_vs_c.ml

  • Committer: Nicolas Palix
  • Date: 2010-01-28 14:23:49 UTC
  • Revision ID: git-v1:70d17887795852eca805bfe27745b9810c0a39be
Remove trailing whitespace/tab

svn path=/coccinelle/; revision=8684

Show diffs side-by-side

added added

removed removed

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