Commit | Line | Data |
---|---|---|
34e49164 | 1 | (* |
faf9a90c | 2 | * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen |
34e49164 C |
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 | ||
b1b2de81 C |
77 | let same_s saopt sbopt = |
78 | match saopt, sbopt with | |
79 | | None, None -> true | |
80 | | Some namea, Some nameb -> | |
81 | let sa = Ast_c.str_of_name namea in | |
82 | let sb = Ast_c.str_of_name nameb in | |
83 | sa =$= sb | |
84 | | _ -> false | |
85 | ||
86 | ||
34e49164 C |
87 | let rec fullType a b = |
88 | let ((qua,iiqa), tya) = a in | |
89 | let ((qub,iiqb), tyb) = b in | |
90 | (qua.const =:= qub.const && qua.volatile =:= qub.volatile) >&&> | |
91 | ||
92 | let (qu,iiq) = (qua, iiqa) in | |
93 | typeC tya tyb >>= (fun ty -> | |
94 | return ((qu,iiq), ty) | |
95 | ) | |
96 | ||
97 | and typeC tya tyb = | |
98 | let (a, iia) = tya in | |
99 | let (b, iib) = tyb in | |
100 | ||
101 | let iix = iia in | |
102 | ||
103 | match a, b with | |
104 | | BaseType a, BaseType b -> | |
105 | a =*= b >&&> return (BaseType a, iix) | |
106 | | Pointer a, Pointer b -> | |
107 | fullType a b >>= (fun x -> return (Pointer x, iix)) | |
108 | ||
109 | | StructUnionName (sua, sa), StructUnionName (sub, sb) -> | |
110 | (sua =*= sub && sa =$= sb) >&&> | |
111 | return (StructUnionName (sua, sa), iix) | |
112 | ||
b1b2de81 C |
113 | | TypeName (namea, opta), TypeName (nameb, optb) -> |
114 | let sa = Ast_c.str_of_name namea in | |
115 | let sb = Ast_c.str_of_name nameb in | |
116 | ||
34e49164 C |
117 | (* assert compatible opta optb ? *) |
118 | (*option fullType opta optb*) | |
119 | sa =$= sb >&&> | |
120 | let opt = | |
121 | (match opta, optb with | |
122 | | None, None -> None | |
b1b2de81 | 123 | |
34e49164 C |
124 | | Some x, _ |
125 | | _, Some x | |
b1b2de81 | 126 | |
34e49164 C |
127 | -> Some x |
128 | ) | |
129 | in | |
b1b2de81 | 130 | return (TypeName (namea, opt), iix) |
34e49164 C |
131 | |
132 | ||
133 | | Array (ea, a), Array (eb,b) -> | |
134 | let get_option f = function Some x -> Some (f x) | None -> None in | |
135 | let ea = get_option Lib_parsing_c.al_expr ea in | |
136 | let eb = get_option Lib_parsing_c.al_expr eb in | |
137 | ea =*= eb >&&> fullType a b >>= (fun x -> return (Array (ea, x), iix)) | |
138 | ||
139 | | FunctionType (returna, paramsa), FunctionType (returnb, paramsb) -> | |
140 | let (tsa, (ba,iihas3dotsa)) = paramsa in | |
141 | let (tsb, (bb,iihas3dotsb)) = paramsb in | |
142 | ||
143 | let bx = ba in | |
144 | let iihas3dotsx = iihas3dotsa in | |
145 | ||
b1b2de81 | 146 | (ba =:= bb && List.length tsa =|= List.length tsb) >&&> |
34e49164 C |
147 | fullType returna returnb >>= (fun returnx -> |
148 | ||
149 | Common.zip tsa tsb +> List.fold_left | |
150 | (fun acc ((parama,iia),(paramb,iib))-> | |
151 | let iix = iia in | |
152 | acc >>= (fun xs -> | |
153 | ||
b1b2de81 C |
154 | let {p_register = (ba,iiba); p_namei = saopt; p_type = ta} = |
155 | parama in | |
156 | let {p_register = (bb,iibb); p_namei = sbopt; p_type = tb} = | |
157 | paramb in | |
34e49164 C |
158 | |
159 | let bx = ba in | |
b1b2de81 C |
160 | let iibx = iiba in |
161 | ||
34e49164 | 162 | let sxopt = saopt in |
b1b2de81 | 163 | |
34e49164 | 164 | |
485bce71 | 165 | (* todo? iso on name or argument ? *) |
b1b2de81 | 166 | (ba =:= bb && same_s saopt sbopt) >&&> |
34e49164 | 167 | fullType ta tb >>= (fun tx -> |
b1b2de81 C |
168 | let paramx = { p_register = (bx, iibx); |
169 | p_namei = sxopt; | |
170 | p_type = tx; } in | |
34e49164 C |
171 | return ((paramx,iix)::xs) |
172 | ) | |
173 | ) | |
174 | ) (return []) | |
175 | >>= (fun tsx -> | |
176 | let paramsx = (List.rev tsx, (bx, iihas3dotsx)) in | |
177 | return (FunctionType (returnx, paramsx), iix) | |
178 | )) | |
179 | ||
180 | | Enum (saopt, enuma), Enum (sbopt, enumb) -> | |
181 | (saopt =*= sbopt && | |
b1b2de81 | 182 | List.length enuma =|= List.length enumb && |
34e49164 | 183 | Common.zip enuma enumb +> List.for_all (fun |
b1b2de81 | 184 | (((namesa,eopta), iicommaa), ((namesb,eoptb),iicommab)) |
34e49164 | 185 | -> |
b1b2de81 C |
186 | let sa = str_of_name namesa in |
187 | let sb = str_of_name namesb in | |
34e49164 | 188 | sa =$= sb && |
b1b2de81 | 189 | (* todo ? eopta and b can have some info so ok to use =*= ? *) |
34e49164 C |
190 | eopta =*= eoptb |
191 | ) | |
192 | ) >&&> | |
193 | return (Enum (saopt, enuma), iix) | |
194 | ||
195 | | EnumName sa, EnumName sb -> sa =$= sb >&&> return (EnumName sa, iix) | |
196 | ||
197 | | ParenType a, ParenType b -> | |
198 | (* iso here ? *) | |
199 | fullType a b >>= (fun x -> | |
200 | return (ParenType x, iix) | |
201 | ) | |
202 | ||
203 | | TypeOfExpr ea, TypeOfExpr eb -> | |
204 | let ea = Lib_parsing_c.al_expr ea in | |
205 | let eb = Lib_parsing_c.al_expr eb in | |
206 | ea =*= eb >&&> return (TypeOfExpr ea, iix) | |
207 | ||
208 | | TypeOfType a, TypeOfType b -> | |
209 | fullType a b >>= (fun x -> return (TypeOfType x, iix)) | |
210 | ||
211 | (* | TypeOfType a, b -> | |
212 | | a, TypeOfType b -> | |
213 | *) | |
214 | ||
215 | ||
216 | | StructUnion (sua, saopt, sta), StructUnion (sub, sbopt, stb) -> | |
b1b2de81 | 217 | (sua =*= sub && saopt =*= sbopt && List.length sta =|= List.length stb) |
34e49164 C |
218 | >&&> |
219 | Common.zip sta stb +> List.fold_left | |
708f4980 | 220 | (fun acc ((fielda), (fieldb)) -> |
34e49164 | 221 | acc >>= (fun xs -> |
708f4980 C |
222 | match fielda, fieldb with |
223 | | EmptyField iia, EmptyField iib -> | |
224 | let iix = iia in | |
225 | return ((EmptyField iix)::xs) | |
34e49164 | 226 | |
485bce71 C |
227 | | DeclarationField (FieldDeclList (fa, iipta)), |
228 | DeclarationField (FieldDeclList (fb, iiptb)) -> | |
229 | let iipt = iipta in (* TODO ?*) | |
34e49164 C |
230 | (List.length fa =|= List.length fb) >&&> |
231 | ||
232 | Common.zip fa fb +> List.fold_left | |
233 | (fun acc2 ((fielda,iia),(fieldb,iib))-> | |
234 | let iix = iia in | |
235 | acc2 >>= (fun xs -> | |
b1b2de81 C |
236 | match fielda, fieldb with |
237 | | Simple (nameaopt, ta), Simple (namebopt, tb) -> | |
238 | ||
239 | ||
240 | same_s nameaopt namebopt >&&> | |
34e49164 | 241 | fullType ta tb >>= (fun tx -> |
b1b2de81 | 242 | return (((Simple (nameaopt, tx)), iix)::xs) |
34e49164 C |
243 | ) |
244 | ||
b1b2de81 C |
245 | | BitField (nameopta, ta, infoa, ea), |
246 | BitField (nameoptb, tb, infob, eb) -> | |
247 | let infox = infoa in | |
248 | (same_s nameopta nameoptb && ea =*= eb) >&&> | |
34e49164 | 249 | fullType ta tb >>= (fun tx -> |
b1b2de81 | 250 | return (((BitField (nameopta,tx,infox,ea)), iix)::xs) |
34e49164 C |
251 | ) |
252 | | _,_ -> fail | |
253 | ) | |
254 | ) (return []) | |
255 | >>= (fun fx -> | |
485bce71 | 256 | return (((DeclarationField |
708f4980 | 257 | (FieldDeclList (List.rev fx,iipt))))::xs) |
34e49164 C |
258 | ) |
259 | | _ -> fail | |
260 | ) | |
261 | ||
262 | ||
263 | ) (return []) | |
264 | >>= (fun stx -> | |
265 | return (StructUnion (sua, saopt, List.rev stx), iix) | |
266 | ) | |
267 | ||
268 | ||
269 | ||
270 | (* choose the lub. | |
271 | * subtil: in the return must put iia, not iix, and in following case | |
272 | * must put iib and not iix, because we want the token corresponding | |
273 | * to the typedef. | |
274 | *) | |
b1b2de81 | 275 | | TypeName (name, Some a), _ -> |
34e49164 | 276 | fullType a (Ast_c.nQ, tyb) >>= (fun x -> |
b1b2de81 | 277 | return (TypeName (name, Some x), iia) |
34e49164 C |
278 | ) |
279 | ||
b1b2de81 | 280 | | _, TypeName (name, Some b) -> |
34e49164 | 281 | fullType b (Ast_c.nQ, tya) >>= (fun x -> |
b1b2de81 | 282 | return (TypeName (name, Some x), iib) (* subtil: *) |
34e49164 C |
283 | ) |
284 | ||
285 | | _, _ -> fail | |
286 | ||
287 | ||
288 | ||
289 | end | |
290 | ||
291 | module XEQ = struct | |
292 | type tin = unit | |
293 | type 'a tout = 'a option | |
294 | ||
295 | type 'a matcher = 'a -> 'a -> tin -> 'a tout | |
296 | ||
297 | let return x = fun tin -> Some x | |
298 | let fail = fun tin -> None | |
299 | ||
300 | let (>>=) m f = fun tin -> | |
301 | match m tin with | |
302 | | None -> None | |
303 | | Some x -> f x tin | |
304 | ||
305 | let (>&&>) b m = fun tin -> | |
306 | if b then m tin | |
307 | else fail tin | |
308 | ||
309 | end | |
310 | ||
311 | module EQ = C_VS_C (XEQ) | |
312 | ||
313 | ||
314 | let eq_type2 a b = EQ.fullType a b () <> None | |
315 | let merge_type2 a b = Common.some (EQ.fullType a b ()) | |
316 | ||
317 | let eq_type a b = | |
318 | Common.profile_code "C_vs_c" (fun () -> eq_type2 a b) | |
319 | ||
320 | let merge_type a b = | |
321 | Common.profile_code "C_vs_c" (fun () -> merge_type2 a b) |