Commit | Line | Data |
---|---|---|
34e49164 C |
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 | ||
485bce71 | 146 | (* todo? iso on name or argument ? *) |
34e49164 C |
147 | (ba =:= bb && saopt =*= sbopt) >&&> |
148 | fullType ta tb >>= (fun tx -> | |
149 | let paramx = (((bx, sxopt, tx), ii_b_sx)) in | |
150 | return ((paramx,iix)::xs) | |
151 | ) | |
152 | ) | |
153 | ) (return []) | |
154 | >>= (fun tsx -> | |
155 | let paramsx = (List.rev tsx, (bx, iihas3dotsx)) in | |
156 | return (FunctionType (returnx, paramsx), iix) | |
157 | )) | |
158 | ||
159 | | Enum (saopt, enuma), Enum (sbopt, enumb) -> | |
160 | (saopt =*= sbopt && | |
161 | List.length enuma = List.length enumb && | |
162 | Common.zip enuma enumb +> List.for_all (fun | |
163 | ((((sa, eopta),ii_s_eqa), iicommaa), (((sb, eoptb),ii_s_eqb),iicommab)) | |
164 | -> | |
165 | sa =$= sb && | |
166 | eopta =*= eoptb | |
167 | ) | |
168 | ) >&&> | |
169 | return (Enum (saopt, enuma), iix) | |
170 | ||
171 | | EnumName sa, EnumName sb -> sa =$= sb >&&> return (EnumName sa, iix) | |
172 | ||
173 | | ParenType a, ParenType b -> | |
174 | (* iso here ? *) | |
175 | fullType a b >>= (fun x -> | |
176 | return (ParenType x, iix) | |
177 | ) | |
178 | ||
179 | | TypeOfExpr ea, TypeOfExpr eb -> | |
180 | let ea = Lib_parsing_c.al_expr ea in | |
181 | let eb = Lib_parsing_c.al_expr eb in | |
182 | ea =*= eb >&&> return (TypeOfExpr ea, iix) | |
183 | ||
184 | | TypeOfType a, TypeOfType b -> | |
185 | fullType a b >>= (fun x -> return (TypeOfType x, iix)) | |
186 | ||
187 | (* | TypeOfType a, b -> | |
188 | | a, TypeOfType b -> | |
189 | *) | |
190 | ||
191 | ||
192 | | StructUnion (sua, saopt, sta), StructUnion (sub, sbopt, stb) -> | |
193 | (sua =*= sub && saopt =*= sbopt && List.length sta = List.length stb) | |
194 | >&&> | |
195 | Common.zip sta stb +> List.fold_left | |
196 | (fun acc ((xfielda, iia), (xfieldb, iib)) -> | |
197 | let iix = iia in | |
198 | acc >>= (fun xs -> | |
199 | match xfielda, xfieldb with | |
200 | | EmptyField, EmptyField -> return ((EmptyField, iix)::xs) | |
201 | ||
485bce71 C |
202 | | DeclarationField (FieldDeclList (fa, iipta)), |
203 | DeclarationField (FieldDeclList (fb, iiptb)) -> | |
204 | let iipt = iipta in (* TODO ?*) | |
34e49164 C |
205 | (List.length fa =|= List.length fb) >&&> |
206 | ||
207 | Common.zip fa fb +> List.fold_left | |
208 | (fun acc2 ((fielda,iia),(fieldb,iib))-> | |
209 | let iix = iia in | |
210 | acc2 >>= (fun xs -> | |
211 | let (fa, ii2a) = fielda in | |
212 | let (fb, ii2b) = fieldb in | |
213 | let ii2x = ii2a in | |
214 | match fa, fb with | |
215 | | Simple (saopt, ta), Simple (sbopt, tb) -> | |
216 | saopt =*= sbopt >&&> | |
217 | fullType ta tb >>= (fun tx -> | |
218 | return (((Simple (saopt, tx), ii2x), iix)::xs) | |
219 | ) | |
220 | ||
221 | | BitField (sopta, ta, ea), BitField (soptb, tb, eb) -> | |
222 | (sopta =*= soptb && ea =*= eb) >&&> | |
223 | fullType ta tb >>= (fun tx -> | |
224 | return (((BitField (sopta,tx,ea), ii2x), iix)::xs) | |
225 | ) | |
226 | | _,_ -> fail | |
227 | ) | |
228 | ) (return []) | |
229 | >>= (fun fx -> | |
485bce71 C |
230 | return (((DeclarationField |
231 | (FieldDeclList (List.rev fx,iipt))), iix)::xs) | |
34e49164 C |
232 | ) |
233 | | _ -> fail | |
234 | ) | |
235 | ||
236 | ||
237 | ) (return []) | |
238 | >>= (fun stx -> | |
239 | return (StructUnion (sua, saopt, List.rev stx), iix) | |
240 | ) | |
241 | ||
242 | ||
243 | ||
244 | (* choose the lub. | |
245 | * subtil: in the return must put iia, not iix, and in following case | |
246 | * must put iib and not iix, because we want the token corresponding | |
247 | * to the typedef. | |
248 | *) | |
249 | | TypeName (s, Some a), _ -> | |
250 | fullType a (Ast_c.nQ, tyb) >>= (fun x -> | |
251 | return (TypeName (s, Some x), iia) | |
252 | ) | |
253 | ||
254 | | _, TypeName (s, Some b) -> | |
255 | fullType b (Ast_c.nQ, tya) >>= (fun x -> | |
256 | return (TypeName (s, Some x), iib) (* subtil: *) | |
257 | ) | |
258 | ||
259 | | _, _ -> fail | |
260 | ||
261 | ||
262 | ||
263 | end | |
264 | ||
265 | module XEQ = struct | |
266 | type tin = unit | |
267 | type 'a tout = 'a option | |
268 | ||
269 | type 'a matcher = 'a -> 'a -> tin -> 'a tout | |
270 | ||
271 | let return x = fun tin -> Some x | |
272 | let fail = fun tin -> None | |
273 | ||
274 | let (>>=) m f = fun tin -> | |
275 | match m tin with | |
276 | | None -> None | |
277 | | Some x -> f x tin | |
278 | ||
279 | let (>&&>) b m = fun tin -> | |
280 | if b then m tin | |
281 | else fail tin | |
282 | ||
283 | end | |
284 | ||
285 | module EQ = C_VS_C (XEQ) | |
286 | ||
287 | ||
288 | let eq_type2 a b = EQ.fullType a b () <> None | |
289 | let merge_type2 a b = Common.some (EQ.fullType a b ()) | |
290 | ||
291 | let eq_type a b = | |
292 | Common.profile_code "C_vs_c" (fun () -> eq_type2 a b) | |
293 | ||
294 | let merge_type a b = | |
295 | Common.profile_code "C_vs_c" (fun () -> merge_type2 a b) |