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.
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.
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.
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/>.
18 * The authors reserve the right to distribute this or future versions of
19 * Coccinelle under other licenses.
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.
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 ?
42 type 'a matcher
= 'a
-> 'a
-> tin
-> 'a tout
46 ('a
-> (tin
-> 'b tout
)) ->
49 val (>&&>) : bool -> (tin
-> 'x tout
) -> (tin
-> 'x tout
)
51 val return
: 'a
-> tin
-> 'a tout
52 val fail
: tin
-> 'a tout
57 functor (X
: PARAM
) ->
60 type 'a matcher
= 'a
-> 'a
-> X.tin
-> 'a
X.tout
67 let (option: 'a matcher
-> ('a
option matcher
)) = fun f t1 t2
->
69 | (Some t1
, Some t2
) ->
73 | (None
, None
) -> return None
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
) >&&>
82 let (qu
,iiq
) = (qua
, iiqa
) in
83 typeC tya tyb
>>= (fun ty
->
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))
99 | StructUnionName
(sua
, sa
), StructUnionName
(sub
, sb
) ->
100 (sua
=*= sub
&& sa
=$
= sb
) >&&>
101 return (StructUnionName
(sua
, sa
), iix)
103 | TypeName
(sa
, opta
), TypeName
(sb
, optb
) ->
104 (* assert compatible opta optb ? *)
105 (*option fullType opta optb*)
108 (match opta
, optb
with
115 return (TypeName
(sa
, opt), iix)
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))
124 | FunctionType
(returna
, paramsa
), FunctionType
(returnb
, paramsb
) ->
125 let (tsa
, (ba
,iihas3dotsa
)) = paramsa
in
126 let (tsb
, (bb
,iihas3dotsb
)) = paramsb
in
129 let iihas3dotsx = iihas3dotsa
in
131 (ba
= bb
&& List.length tsa
= List.length tsb
) >&&>
132 fullType returna returnb
>>= (fun returnx
->
134 Common.zip tsa tsb
+> List.fold_left
135 (fun acc
((parama
,iia
),(paramb
,iib
))->
139 let (((ba
, saopt
, ta
), ii_b_sa
)) = parama
in
140 let (((bb
, sbopt
, tb
), ii_b_sb
)) = paramb
in
144 let ii_b_sx = ii_b_sa
in
146 (* todo? iso on name or argument ? *)
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
)
155 let paramsx = (List.rev tsx
, (bx, iihas3dotsx)) in
156 return (FunctionType
(returnx
, paramsx), iix)
159 | Enum
(saopt
, enuma
), Enum
(sbopt
, enumb
) ->
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
))
169 return (Enum
(saopt
, enuma
), iix)
171 | EnumName sa
, EnumName sb
-> sa
=$
= sb
>&&> return (EnumName sa
, iix)
173 | ParenType a
, ParenType b
->
175 fullType a b
>>= (fun x
->
176 return (ParenType x
, iix)
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)
184 | TypeOfType a
, TypeOfType b
->
185 fullType a b
>>= (fun x
-> return (TypeOfType x
, iix))
187 (* | TypeOfType a, b ->
192 | StructUnion
(sua
, saopt
, sta
), StructUnion
(sub
, sbopt
, stb
) ->
193 (sua
=*= sub
&& saopt
=*= sbopt
&& List.length sta
= List.length stb
)
195 Common.zip sta stb
+> List.fold_left
196 (fun acc
((xfielda
, iia
), (xfieldb
, iib
)) ->
199 match xfielda
, xfieldb
with
200 | EmptyField
, EmptyField
-> return ((EmptyField
, iix)::xs
)
202 | DeclarationField
(FieldDeclList
(fa
, iipta
)),
203 DeclarationField
(FieldDeclList
(fb
, iiptb
)) ->
204 let iipt = iipta
in (* TODO ?*)
205 (List.length fa
=|= List.length fb
) >&&>
207 Common.zip fa fb
+> List.fold_left
208 (fun acc2
((fielda
,iia
),(fieldb
,iib
))->
211 let (fa
, ii2a
) = fielda
in
212 let (fb
, ii2b
) = fieldb
in
215 | Simple
(saopt
, ta
), Simple
(sbopt
, tb
) ->
217 fullType ta tb
>>= (fun tx
->
218 return (((Simple
(saopt
, tx
), ii2x), iix)::xs
)
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
)
230 return (((DeclarationField
231 (FieldDeclList
(List.rev fx
,iipt))), iix)::xs
)
239 return (StructUnion
(sua
, saopt
, List.rev stx
), iix)
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
249 | TypeName
(s
, Some a
), _
->
250 fullType a
(Ast_c.nQ
, tyb
) >>= (fun x
->
251 return (TypeName
(s
, Some x
), iia
)
254 | _
, TypeName
(s
, Some b
) ->
255 fullType b
(Ast_c.nQ
, tya
) >>= (fun x
->
256 return (TypeName
(s
, Some x
), iib
) (* subtil: *)
267 type 'a tout
= 'a
option
269 type 'a matcher
= 'a
-> 'a
-> tin
-> 'a tout
271 let return x
= fun tin
-> Some x
272 let fail = fun tin
-> None
274 let (>>=) m f
= fun tin
->
279 let (>&&>) b m
= fun tin
->
285 module EQ
= C_VS_C
(XEQ
)
288 let eq_type2 a b
= EQ.fullType a b
() <> None
289 let merge_type2 a b
= Common.some
(EQ.fullType a b
())
292 Common.profile_code
"C_vs_c" (fun () -> eq_type2 a b
)
295 Common.profile_code
"C_vs_c" (fun () -> merge_type2 a b
)