Commit | Line | Data |
---|---|---|
f537ebc4 | 1 | (* |
17ba0788 C |
2 | * Copyright 2012, INRIA |
3 | * Julia Lawall, Gilles Muller | |
4 | * Copyright 2010-2011, INRIA, University of Copenhagen | |
f537ebc4 C |
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. | |
d6ce1786 C |
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. | |
f537ebc4 C |
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 | ||
feec80c3 | 54 | # 0 "./c_vs_c.ml" |
34e49164 C |
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. | |
ae4735db | 62 | * |
34e49164 C |
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 | ||
ae4735db C |
69 | module type PARAM = |
70 | sig | |
34e49164 C |
71 | type tin |
72 | type 'x tout | |
73 | ||
74 | type 'a matcher = 'a -> 'a -> tin -> 'a tout | |
75 | ||
ae4735db C |
76 | val (>>=): |
77 | (tin -> 'a tout) -> | |
78 | ('a -> (tin -> 'b tout)) -> | |
34e49164 C |
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 = | |
ae4735db | 89 | functor (X : PARAM) -> |
34e49164 C |
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 | |
ae4735db C |
101 | | (Some t1, Some t2) -> |
102 | f t1 t2 >>= (fun t -> | |
34e49164 C |
103 | return (Some t) |
104 | ) | |
105 | | (None, None) -> return None | |
106 | | _ -> fail | |
107 | ||
108 | ||
ae4735db | 109 | let same_s saopt sbopt = |
b1b2de81 C |
110 | match saopt, sbopt with |
111 | | None, None -> true | |
ae4735db | 112 | | Some namea, Some nameb -> |
b1b2de81 C |
113 | let sa = Ast_c.str_of_name namea in |
114 | let sb = Ast_c.str_of_name nameb in | |
115 | sa =$= sb | |
ae4735db | 116 | | _ -> false |
b1b2de81 C |
117 | |
118 | ||
ae4735db | 119 | let rec fullType a b = |
34e49164 C |
120 | let ((qua,iiqa), tya) = a in |
121 | let ((qub,iiqb), tyb) = b in | |
122 | (qua.const =:= qub.const && qua.volatile =:= qub.volatile) >&&> | |
123 | ||
ae4735db C |
124 | let (qu,iiq) = (qua, iiqa) in |
125 | typeC tya tyb >>= (fun ty -> | |
34e49164 C |
126 | return ((qu,iiq), ty) |
127 | ) | |
128 | ||
ae4735db | 129 | and typeC tya tyb = |
34e49164 C |
130 | let (a, iia) = tya in |
131 | let (b, iib) = tyb in | |
132 | ||
133 | let iix = iia in | |
134 | ||
135 | match a, b with | |
ae4735db | 136 | | BaseType a, BaseType b -> |
34e49164 | 137 | a =*= b >&&> return (BaseType a, iix) |
ae4735db | 138 | | Pointer a, Pointer b -> |
34e49164 C |
139 | fullType a b >>= (fun x -> return (Pointer x, iix)) |
140 | ||
ae4735db C |
141 | | StructUnionName (sua, sa), StructUnionName (sub, sb) -> |
142 | (sua =*= sub && sa =$= sb) >&&> | |
34e49164 C |
143 | return (StructUnionName (sua, sa), iix) |
144 | ||
ae4735db | 145 | | TypeName (namea, opta), TypeName (nameb, optb) -> |
b1b2de81 C |
146 | let sa = Ast_c.str_of_name namea in |
147 | let sb = Ast_c.str_of_name nameb in | |
ae4735db | 148 | |
34e49164 C |
149 | (* assert compatible opta optb ? *) |
150 | (*option fullType opta optb*) | |
ae4735db C |
151 | sa =$= sb >&&> |
152 | let opt = | |
34e49164 C |
153 | (match opta, optb with |
154 | | None, None -> None | |
b1b2de81 | 155 | |
ae4735db C |
156 | | Some x, _ |
157 | | _, Some x | |
b1b2de81 | 158 | |
34e49164 | 159 | -> Some x |
ae4735db | 160 | ) |
34e49164 | 161 | in |
b1b2de81 | 162 | return (TypeName (namea, opt), iix) |
34e49164 | 163 | |
ae4735db C |
164 | |
165 | | Array (ea, a), Array (eb,b) -> | |
34e49164 C |
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 | ||
ae4735db | 171 | | FunctionType (returna, paramsa), FunctionType (returnb, paramsb) -> |
34e49164 C |
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 | ||
b1b2de81 | 178 | (ba =:= bb && List.length tsa =|= List.length tsb) >&&> |
ae4735db | 179 | fullType returna returnb >>= (fun returnx -> |
34e49164 | 180 | |
ae4735db | 181 | Common.zip tsa tsb +> List.fold_left |
34e49164 C |
182 | (fun acc ((parama,iia),(paramb,iib))-> |
183 | let iix = iia in | |
ae4735db | 184 | acc >>= (fun xs -> |
34e49164 | 185 | |
ae4735db | 186 | let {p_register = (ba,iiba); p_namei = saopt; p_type = ta} = |
b1b2de81 | 187 | parama in |
ae4735db | 188 | let {p_register = (bb,iibb); p_namei = sbopt; p_type = tb} = |
b1b2de81 | 189 | paramb in |
34e49164 C |
190 | |
191 | let bx = ba in | |
b1b2de81 C |
192 | let iibx = iiba in |
193 | ||
34e49164 | 194 | let sxopt = saopt in |
b1b2de81 | 195 | |
34e49164 | 196 | |
485bce71 | 197 | (* todo? iso on name or argument ? *) |
b1b2de81 | 198 | (ba =:= bb && same_s saopt sbopt) >&&> |
ae4735db | 199 | fullType ta tb >>= (fun tx -> |
b1b2de81 C |
200 | let paramx = { p_register = (bx, iibx); |
201 | p_namei = sxopt; | |
202 | p_type = tx; } in | |
34e49164 C |
203 | return ((paramx,iix)::xs) |
204 | ) | |
205 | ) | |
206 | ) (return []) | |
ae4735db | 207 | >>= (fun tsx -> |
34e49164 C |
208 | let paramsx = (List.rev tsx, (bx, iihas3dotsx)) in |
209 | return (FunctionType (returnx, paramsx), iix) | |
210 | )) | |
211 | ||
ae4735db | 212 | | Enum (saopt, enuma), Enum (sbopt, enumb) -> |
34e49164 | 213 | (saopt =*= sbopt && |
ae4735db C |
214 | List.length enuma =|= List.length enumb && |
215 | Common.zip enuma enumb +> List.for_all (fun | |
b1b2de81 | 216 | (((namesa,eopta), iicommaa), ((namesb,eoptb),iicommab)) |
ae4735db | 217 | -> |
b1b2de81 C |
218 | let sa = str_of_name namesa in |
219 | let sb = str_of_name namesb in | |
ae4735db | 220 | sa =$= sb && |
b1b2de81 | 221 | (* todo ? eopta and b can have some info so ok to use =*= ? *) |
ae4735db | 222 | eopta =*= eoptb |
34e49164 C |
223 | ) |
224 | ) >&&> | |
225 | return (Enum (saopt, enuma), iix) | |
226 | ||
227 | | EnumName sa, EnumName sb -> sa =$= sb >&&> return (EnumName sa, iix) | |
228 | ||
ae4735db | 229 | | ParenType a, ParenType b -> |
34e49164 | 230 | (* iso here ? *) |
ae4735db | 231 | fullType a b >>= (fun x -> |
34e49164 C |
232 | return (ParenType x, iix) |
233 | ) | |
234 | ||
ae4735db | 235 | | TypeOfExpr ea, TypeOfExpr eb -> |
34e49164 C |
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 | ||
ae4735db | 240 | | TypeOfType a, TypeOfType b -> |
34e49164 C |
241 | fullType a b >>= (fun x -> return (TypeOfType x, iix)) |
242 | ||
ae4735db C |
243 | (* | TypeOfType a, b -> |
244 | | a, TypeOfType b -> | |
34e49164 C |
245 | *) |
246 | ||
247 | ||
ae4735db C |
248 | | StructUnion (sua, saopt, sta), StructUnion (sub, sbopt, stb) -> |
249 | (sua =*= sub && saopt =*= sbopt && List.length sta =|= List.length stb) | |
250 | >&&> | |
17ba0788 C |
251 | (function tin -> |
252 | (* zip is only safe if the above succeeds *) | |
253 | (Common.zip sta stb +> List.fold_left | |
ae4735db C |
254 | (fun acc ((fielda), (fieldb)) -> |
255 | acc >>= (fun xs -> | |
256 | match fielda, fieldb with | |
257 | | EmptyField iia, EmptyField iib -> | |
708f4980 C |
258 | let iix = iia in |
259 | return ((EmptyField iix)::xs) | |
34e49164 | 260 | |
ae4735db C |
261 | | DeclarationField (FieldDeclList (fa, iipta)), |
262 | DeclarationField (FieldDeclList (fb, iiptb)) -> | |
485bce71 | 263 | let iipt = iipta in (* TODO ?*) |
ae4735db | 264 | (List.length fa =|= List.length fb) >&&> |
17ba0788 C |
265 | (function tin -> |
266 | (* only executable if the length is correct *) | |
267 | (Common.zip fa fb +> List.fold_left | |
ae4735db | 268 | (fun acc2 ((fielda,iia),(fieldb,iib))-> |
34e49164 | 269 | let iix = iia in |
ae4735db | 270 | acc2 >>= (fun xs -> |
b1b2de81 | 271 | match fielda, fieldb with |
ae4735db | 272 | | Simple (nameaopt, ta), Simple (namebopt, tb) -> |
b1b2de81 | 273 | |
ae4735db C |
274 | |
275 | same_s nameaopt namebopt >&&> | |
276 | fullType ta tb >>= (fun tx -> | |
b1b2de81 | 277 | return (((Simple (nameaopt, tx)), iix)::xs) |
34e49164 | 278 | ) |
ae4735db C |
279 | |
280 | | BitField (nameopta, ta, infoa, ea), | |
281 | BitField (nameoptb, tb, infob, eb) -> | |
b1b2de81 | 282 | let infox = infoa in |
ae4735db C |
283 | (same_s nameopta nameoptb && ea =*= eb) >&&> |
284 | fullType ta tb >>= (fun tx -> | |
b1b2de81 | 285 | return (((BitField (nameopta,tx,infox,ea)), iix)::xs) |
34e49164 C |
286 | ) |
287 | | _,_ -> fail | |
288 | ) | |
17ba0788 | 289 | ) (return [])) tin) |
ae4735db C |
290 | >>= (fun fx -> |
291 | return (((DeclarationField | |
708f4980 | 292 | (FieldDeclList (List.rev fx,iipt))))::xs) |
34e49164 C |
293 | ) |
294 | | _ -> fail | |
295 | ) | |
296 | ||
297 | ||
298 | ) (return []) | |
ae4735db | 299 | >>= (fun stx -> |
34e49164 | 300 | return (StructUnion (sua, saopt, List.rev stx), iix) |
17ba0788 | 301 | )) tin) |
34e49164 C |
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 | *) | |
ae4735db C |
310 | | TypeName (name, Some a), _ -> |
311 | fullType a (Ast_c.nQ, tyb) >>= (fun x -> | |
312 | return (TypeName (name, Some x), iia) | |
34e49164 C |
313 | ) |
314 | ||
ae4735db C |
315 | | _, TypeName (name, Some b) -> |
316 | fullType b (Ast_c.nQ, tya) >>= (fun x -> | |
b1b2de81 | 317 | return (TypeName (name, Some x), iib) (* subtil: *) |
34e49164 C |
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 | ||
ae4735db | 335 | let (>>=) m f = fun tin -> |
34e49164 C |
336 | match m tin with |
337 | | None -> None | |
338 | | Some x -> f x tin | |
339 | ||
ae4735db | 340 | let (>&&>) b m = fun tin -> |
34e49164 C |
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 | ||
ae4735db | 352 | let eq_type a b = |
34e49164 C |
353 | Common.profile_code "C_vs_c" (fun () -> eq_type2 a b) |
354 | ||
ae4735db | 355 | let merge_type a b = |
34e49164 | 356 | Common.profile_code "C_vs_c" (fun () -> merge_type2 a b) |
5636bb2c C |
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 |