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.
23 (* --------------------------------------------------------------------- *)
24 (* Given two patterns, A and B, determine whether B can match any matched
25 subterms of A. For simplicity, this doesn't maintain an environment; it
26 just assume metavariables match. Thus the result is either NO or MAYBE. *)
28 module Ast
= Ast_cocci
29 module V
= Visitor_ast
31 (* --------------------------------------------------------------------- *)
35 let return b
= if b
then MAYBE
else NO
37 let unify_mcode (x
,_
,_
,_
) (y
,_
,_
,_
) = x
= y
39 let unify_option f t1 t2
=
41 (Some t1
, Some t2
) -> f t1 t2
42 | (None
, None
) -> return true
45 let unify_true_option f t1 t2
=
47 (Some t1
, Some t2
) -> f t1 t2
48 | (None
, None
) -> return true
51 let bool_unify_option f t1 t2
=
53 (Some t1
, Some t2
) -> f t1 t2
54 | (None
, None
) -> true
57 let conjunct_bindings b1 b2
=
58 match b1
with NO
-> b1
| MAYBE
-> b2
60 let disjunct_bindings b1 b2
=
61 match b1
with MAYBE
-> b1
| NO
-> b2
63 let disjunct_all_bindings = List.fold_left
disjunct_bindings NO
65 (* --------------------------------------------------------------------- *)
67 (* compute the common prefix. if in at least one case, this ends with the
68 end of the pattern or a ..., then return true. *)
70 let unify_lists fn dfn la lb
=
71 let rec loop = function
72 ([],_
) | (_
,[]) -> return true
73 | (cura
::resta
,curb
::restb
) ->
74 (match fn cura curb
with
75 MAYBE
-> loop (resta
,restb
)
76 | NO
-> if dfn cura
or dfn curb
then MAYBE
else NO
) in
79 let unify_dots fn dfn d1 d2
=
80 match (Ast.unwrap d1
,Ast.unwrap d2
) with
81 (Ast.DOTS
(l1
),Ast.DOTS
(l2
))
82 | (Ast.CIRCLES
(l1
),Ast.CIRCLES
(l2
))
83 | (Ast.STARS
(l1
),Ast.STARS
(l2
)) -> unify_lists fn dfn l1 l2
87 match Ast.unwrap e
with
88 Ast.Edots
(_
,_
) | Ast.Ecircles
(_
,_
) | Ast.Estars
(_
,_
) -> true
92 match Ast.unwrap e
with
93 Ast.Ddots
(_
,_
) -> true
97 match Ast.unwrap p
with
98 Ast.Pdots
(_
) | Ast.Pcircles
(_
) -> true
102 match Ast.unwrap e
with
103 Ast.DPdots
(_
) | Ast.DPcircles
(_
) -> true
107 match Ast.unwrap s
with
108 Ast.Dots
(_
,_
,_
,_
) | Ast.Circles
(_
,_
,_
,_
) | Ast.Stars
(_
,_
,_
,_
) -> true
111 (* --------------------------------------------------------------------- *)
114 and unify_ident i1 i2
=
115 match (Ast.unwrap i1
,Ast.unwrap i2
) with
116 (Ast.Id
(i1
),Ast.Id
(i2
)) -> return (unify_mcode i1 i2
)
118 | (Ast.MetaId
(_
,_
,_
,_
),_
)
119 | (Ast.MetaFunc
(_
,_
,_
,_
),_
)
120 | (Ast.MetaLocalFunc
(_
,_
,_
,_
),_
)
121 | (_
,Ast.MetaId
(_
,_
,_
,_
))
122 | (_
,Ast.MetaFunc
(_
,_
,_
,_
))
123 | (_
,Ast.MetaLocalFunc
(_
,_
,_
,_
)) -> return true
125 | (Ast.OptIdent
(_
),_
)
126 | (Ast.UniqueIdent
(_
),_
)
127 | (_
,Ast.OptIdent
(_
))
128 | (_
,Ast.UniqueIdent
(_
)) -> failwith
"unsupported ident"
130 (* --------------------------------------------------------------------- *)
133 let rec unify_expression e1 e2
=
134 match (Ast.unwrap e1
,Ast.unwrap e2
) with
135 (Ast.Ident
(i1
),Ast.Ident
(i2
)) -> unify_ident i1 i2
136 | (Ast.Constant
(c1
),Ast.Constant
(c2
))-> return (unify_mcode c1 c2
)
137 | (Ast.FunCall
(f1
,lp1
,args1
,rp1
),Ast.FunCall
(f2
,lp2
,args2
,rp2
)) ->
139 (unify_expression f1 f2
)
140 (unify_dots unify_expression edots args1 args2
)
141 | (Ast.Assignment
(l1
,op1
,r1
,_
),Ast.Assignment
(l2
,op2
,r2
,_
)) ->
142 if unify_mcode op1 op2
143 then conjunct_bindings (unify_expression l1 l2
) (unify_expression r1 r2
)
145 | (Ast.CondExpr
(tst1
,q1
,thn1
,c1
,els1
),Ast.CondExpr
(tst2
,q2
,thn2
,c2
,els2
)) ->
146 conjunct_bindings (unify_expression tst1 tst2
)
147 (conjunct_bindings (unify_option unify_expression thn1 thn2
)
148 (unify_expression els1 els2
))
149 | (Ast.Postfix
(e1
,op1
),Ast.Postfix
(e2
,op2
)) ->
150 if unify_mcode op1 op2
then unify_expression e1 e2
else return false
151 | (Ast.Infix
(e1
,op1
),Ast.Infix
(e2
,op2
)) ->
152 if unify_mcode op1 op2
then unify_expression e1 e2
else return false
153 | (Ast.Unary
(e1
,op1
),Ast.Unary
(e2
,op2
)) ->
154 if unify_mcode op1 op2
then unify_expression e1 e2
else return false
155 | (Ast.Binary
(l1
,op1
,r1
),Ast.Binary
(l2
,op2
,r2
)) ->
156 if unify_mcode op1 op2
157 then conjunct_bindings (unify_expression l1 l2
) (unify_expression r1 r2
)
159 | (Ast.ArrayAccess
(ar1
,lb1
,e1
,rb1
),Ast.ArrayAccess
(ar2
,lb2
,e2
,rb2
)) ->
160 conjunct_bindings (unify_expression ar1 ar2
) (unify_expression e1 e2
)
161 | (Ast.RecordAccess
(e1
,d1
,fld1
),Ast.RecordAccess
(e2
,d2
,fld2
)) ->
162 conjunct_bindings (unify_expression e1 e2
) (unify_ident fld1 fld2
)
163 | (Ast.RecordPtAccess
(e1
,pt1
,fld1
),Ast.RecordPtAccess
(e2
,pt2
,fld2
)) ->
164 conjunct_bindings (unify_expression e1 e2
) (unify_ident fld1 fld2
)
165 | (Ast.Cast
(lp1
,ty1
,rp1
,e1
),Ast.Cast
(lp2
,ty2
,rp2
,e2
)) ->
166 conjunct_bindings (unify_fullType ty1 ty2
) (unify_expression e1 e2
)
167 | (Ast.SizeOfExpr
(szf1
,e1
),Ast.SizeOfExpr
(szf2
,e2
)) ->
168 unify_expression e1 e2
169 | (Ast.SizeOfType
(szf1
,lp1
,ty1
,rp1
),Ast.SizeOfType
(szf2
,lp2
,ty2
,rp2
)) ->
170 unify_fullType ty1 ty2
171 | (Ast.TypeExp
(ty1
),Ast.TypeExp
(ty2
)) -> unify_fullType ty1 ty2
172 | (Ast.Paren
(lp1
,e1
,rp1
),Ast.Paren
(lp2
,e2
,rp2
)) ->
173 unify_expression e1 e2
175 | (Ast.MetaErr
(_
,_
,_
,_
),_
)
176 | (Ast.MetaExpr
(_
,_
,_
,_
,_
,_
),_
)
177 | (Ast.MetaExprList
(_
,_
,_
,_
),_
)
178 | (_
,Ast.MetaErr
(_
,_
,_
,_
))
179 | (_
,Ast.MetaExpr
(_
,_
,_
,_
,_
,_
))
180 | (_
,Ast.MetaExprList
(_
,_
,_
,_
)) -> return true
182 | (Ast.EComma
(cm1
),Ast.EComma
(cm2
)) -> return true
184 | (Ast.DisjExpr
(e1
),_
) ->
185 disjunct_all_bindings (List.map
(function x
-> unify_expression x e2
) e1
)
186 | (_
,Ast.DisjExpr
(e2
)) ->
187 disjunct_all_bindings (List.map
(function x
-> unify_expression e1 x
) e2
)
188 | (Ast.NestExpr
(e1
,_
,_
),Ast.NestExpr
(e2
,_
,_
)) ->
189 unify_dots unify_expression edots e1 e2
191 (* dots can match against anything. return true to be safe. *)
192 | (Ast.Edots
(_
,_
),_
) | (_
,Ast.Edots
(_
,_
))
193 | (Ast.Ecircles
(_
,_
),_
) | (_
,Ast.Ecircles
(_
,_
))
194 | (Ast.Estars
(_
,_
),_
) | (_
,Ast.Estars
(_
,_
)) -> return true
197 | (Ast.UniqueExp
(_
),_
)
199 | (_
,Ast.UniqueExp
(_
)) -> failwith
"unsupported expression"
202 (* --------------------------------------------------------------------- *)
205 and unify_fullType ft1 ft2
=
206 match (Ast.unwrap ft1
,Ast.unwrap ft2
) with
207 (Ast.Type
(cv1
,ty1
),Ast.Type
(cv2
,ty2
)) ->
208 if bool_unify_option unify_mcode cv1 cv2
209 then unify_typeC ty1 ty2
211 | (Ast.DisjType
(ft1
),_
) ->
212 disjunct_all_bindings (List.map
(function x
-> unify_fullType x ft2
) ft1
)
213 | (_
,Ast.DisjType
(ft2
)) ->
214 disjunct_all_bindings (List.map
(function x
-> unify_fullType ft1 x
) ft2
)
217 | (Ast.UniqueType
(_
),_
)
219 | (_
,Ast.UniqueType
(_
)) -> failwith
"unsupported type"
221 and unify_typeC t1 t2
=
222 match (Ast.unwrap t1
,Ast.unwrap t2
) with
223 (Ast.BaseType
(ty1
,sgn1
),Ast.BaseType
(ty2
,sgn2
)) ->
224 return (unify_mcode ty1 ty2
&& bool_unify_option unify_mcode sgn1 sgn2
)
225 | (Ast.ImplicitInt
(sgn1
),Ast.ImplicitInt
(sgn2
)) ->
226 return (unify_mcode sgn1 sgn2
)
227 | (Ast.Pointer
(ty1
,s1
),Ast.Pointer
(ty2
,s2
)) -> unify_fullType ty1 ty2
228 | (Ast.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa
,rp2a
),
229 Ast.FunctionPointer
(tyb
,lp1b
,starb
,rp1b
,lp2b
,paramsb
,rp2b
)) ->
230 if List.for_all2
unify_mcode
231 [lp1a
;stara
;rp1a
;lp2a
;rp2a
] [lp1b
;starb
;rp1b
;lp2b
;rp2b
]
233 conjunct_bindings (unify_fullType tya tyb
)
234 (unify_dots unify_parameterTypeDef
pdots paramsa paramsb
)
236 | (Ast.FunctionType
(_
,tya
,lp1a
,paramsa
,rp1a
),
237 Ast.FunctionType
(_
,tyb
,lp1b
,paramsb
,rp1b
)) ->
238 if List.for_all2
unify_mcode [lp1a
;rp1a
] [lp1b
;rp1b
]
240 conjunct_bindings (unify_option unify_fullType tya tyb
)
241 (unify_dots unify_parameterTypeDef
pdots paramsa paramsb
)
243 | (Ast.FunctionType _
, _
) -> failwith
"not supported"
244 | (Ast.Array
(ty1
,lb1
,e1
,rb1
),Ast.Array
(ty2
,lb2
,e2
,rb2
)) ->
246 (unify_fullType ty1 ty2
) (unify_option unify_expression e1 e2
)
247 | (Ast.StructUnionName
(s1
,Some ts1
),Ast.StructUnionName
(s2
,Some ts2
)) ->
248 if unify_mcode s1 s2
then unify_ident ts1 ts2
else return false
249 | (Ast.StructUnionName
(s1
,None
),Ast.StructUnionName
(s2
,None
)) ->
251 | (Ast.StructUnionDef
(ty1
,lb1
,decls1
,rb1
),
252 Ast.StructUnionDef
(ty2
,lb2
,decls2
,rb2
)) ->
253 conjunct_bindings (unify_fullType ty1 ty2
)
254 (unify_dots unify_declaration
ddots decls1 decls2
)
255 | (Ast.TypeName
(t1
),Ast.TypeName
(t2
)) -> return (unify_mcode t1 t2
)
257 | (Ast.MetaType
(_
,_
,_
),_
)
258 | (_
,Ast.MetaType
(_
,_
,_
)) -> return true
261 (* --------------------------------------------------------------------- *)
262 (* Variable declaration *)
263 (* Even if the Cocci program specifies a list of declarations, they are
264 split out into multiple declarations of a single variable each. *)
266 and unify_declaration d1 d2
=
267 match (Ast.unwrap d1
,Ast.unwrap d2
) with
268 (Ast.Init
(stg1
,ft1
,id1
,eq1
,i1
,s1
),Ast.Init
(stg2
,ft2
,id2
,eq2
,i2
,s2
)) ->
269 if bool_unify_option unify_mcode stg1 stg2
271 conjunct_bindings (unify_fullType ft1 ft2
)
272 (conjunct_bindings (unify_ident id1 id2
) (unify_initialiser i1 i2
))
274 | (Ast.UnInit
(stg1
,ft1
,id1
,s1
),Ast.UnInit
(stg2
,ft2
,id2
,s2
)) ->
275 if bool_unify_option unify_mcode stg1 stg2
276 then conjunct_bindings (unify_fullType ft1 ft2
) (unify_ident id1 id2
)
278 | (Ast.MacroDecl
(n1
,lp1
,args1
,rp1
,sem1
),
279 Ast.MacroDecl
(n2
,lp2
,args2
,rp2
,sem2
)) ->
280 conjunct_bindings (unify_ident n1 n2
)
281 (unify_dots unify_expression edots args1 args2
)
282 | (Ast.TyDecl
(ft1
,s1
),Ast.TyDecl
(ft2
,s2
)) -> unify_fullType ft1 ft2
283 | (Ast.Typedef
(stg1
,ft1
,id1
,s1
),Ast.Typedef
(stg2
,ft2
,id2
,s2
)) ->
284 conjunct_bindings (unify_fullType ft1 ft2
) (unify_typeC id1 id2
)
285 | (Ast.DisjDecl
(d1
),_
) ->
286 disjunct_all_bindings
287 (List.map
(function x
-> unify_declaration x d2
) d1
)
288 | (_
,Ast.DisjDecl
(d2
)) ->
289 disjunct_all_bindings
290 (List.map
(function x
-> unify_declaration d1 x
) d2
)
291 (* dots can match against anything. return true to be safe. *)
292 | (Ast.Ddots
(_
,_
),_
) | (_
,Ast.Ddots
(_
,_
)) -> return true
295 | (Ast.UniqueDecl
(_
),_
)
297 | (_
,Ast.UniqueDecl
(_
)) -> failwith
"unsupported decl"
300 (* --------------------------------------------------------------------- *)
303 and unify_initialiser i1 i2
=
304 match (Ast.unwrap i1
,Ast.unwrap i2
) with
305 (Ast.InitExpr
(expa
),Ast.InitExpr
(expb
)) ->
306 unify_expression expa expb
307 | (Ast.InitList
(_
,initlista
,_
,whena
),
308 Ast.InitList
(_
,initlistb
,_
,whenb
)) ->
309 (* ignore whencode - returns true safely *)
310 unify_lists unify_initialiser
(function _
-> false) initlista initlistb
311 | (Ast.InitGccDotName
(_
,namea
,_
,inia
),
312 Ast.InitGccDotName
(_
,nameb
,_
,inib
)) ->
314 (unify_ident namea nameb
) (unify_initialiser inia inib
)
315 | (Ast.InitGccName
(namea
,_
,inia
),Ast.InitGccName
(nameb
,_
,inib
)) ->
316 conjunct_bindings (unify_ident namea nameb
) (unify_initialiser inia inib
)
317 | (Ast.InitGccIndex
(_
,expa
,_
,_
,inia
),
318 Ast.InitGccIndex
(_
,expb
,_
,_
,inib
)) ->
320 (unify_expression expa expb
) (unify_initialiser inia inib
)
321 | (Ast.InitGccRange
(_
,exp1a
,_
,exp2a
,_
,_
,inia
),
322 Ast.InitGccRange
(_
,exp1b
,_
,exp2b
,_
,_
,inib
)) ->
323 conjunct_bindings (unify_expression exp1a exp1b
)
324 (conjunct_bindings (unify_expression exp2a exp2b
)
325 (unify_initialiser inia inib
))
328 | (Ast.UniqueIni
(_
),_
)
330 | (_
,Ast.UniqueIni
(_
)) -> failwith
"unsupported decl"
333 (* --------------------------------------------------------------------- *)
336 and unify_parameterTypeDef p1 p2
=
337 match (Ast.unwrap p1
,Ast.unwrap p2
) with
338 (Ast.VoidParam
(ft1
),Ast.VoidParam
(ft2
)) -> unify_fullType ft1 ft2
339 | (Ast.Param
(ft1
,i1
),Ast.Param
(ft2
,i2
)) ->
340 conjunct_bindings (unify_fullType ft1 ft2
)
341 (unify_option unify_ident i1 i2
)
343 | (Ast.MetaParam
(_
,_
,_
),_
)
344 | (Ast.MetaParamList
(_
,_
,_
,_
),_
)
345 | (_
,Ast.MetaParam
(_
,_
,_
))
346 | (_
,Ast.MetaParamList
(_
,_
,_
,_
)) -> return true
348 | (Ast.PComma
(_
),Ast.PComma
(_
)) -> return true
350 (* dots can match against anything. return true to be safe. *)
351 | (Ast.Pdots
(_
),_
) | (_
,Ast.Pdots
(_
))
352 | (Ast.Pcircles
(_
),_
) | (_
,Ast.Pcircles
(_
)) -> return true
354 | (Ast.OptParam
(_
),_
)
355 | (Ast.UniqueParam
(_
),_
)
356 | (_
,Ast.OptParam
(_
))
357 | (_
,Ast.UniqueParam
(_
)) -> failwith
"unsupported parameter"
360 (* --------------------------------------------------------------------- *)
361 (* Define parameter *)
363 and unify_define_parameters p1 p2
=
364 match (Ast.unwrap p1
,Ast.unwrap p2
) with
365 (Ast.NoParams
,Ast.NoParams
) -> return true
366 | (Ast.DParams
(lp1
,params1
,rp1
),Ast.DParams
(lp2
,params2
,rp2
)) ->
367 unify_dots unify_define_param
dpdots params1 params2
370 and unify_define_param p1 p2
=
371 match (Ast.unwrap p1
,Ast.unwrap p2
) with
372 (Ast.DParam
(i1
),Ast.DParam
(i2
)) ->
374 | (Ast.DPComma
(_
),Ast.DPComma
(_
)) -> return true
376 (* dots can match against anything. return true to be safe. *)
377 | (Ast.DPdots
(_
),_
) | (_
,Ast.DPdots
(_
))
378 | (Ast.DPcircles
(_
),_
) | (_
,Ast.DPcircles
(_
)) -> return true
380 | (Ast.OptDParam
(_
),_
)
381 | (Ast.UniqueDParam
(_
),_
)
382 | (_
,Ast.OptDParam
(_
))
383 | (_
,Ast.UniqueDParam
(_
)) -> failwith
"unsupported parameter"
386 (* --------------------------------------------------------------------- *)
389 and unify_rule_elem re1 re2
=
390 match (Ast.unwrap re1
,Ast.unwrap re2
) with
391 (Ast.FunHeader
(_
,_
,fi1
,nm1
,lp1
,params1
,rp1
),
392 Ast.FunHeader
(_
,_
,fi2
,nm2
,lp2
,params2
,rp2
)) ->
393 conjunct_bindings (unify_fninfo fi1 fi2
)
394 (conjunct_bindings (unify_ident nm1 nm2
)
395 (unify_dots unify_parameterTypeDef
pdots params1 params2
))
396 | (Ast.Decl
(_
,_
,d1
),Ast.Decl
(_
,_
,d2
)) -> unify_declaration d1 d2
398 | (Ast.SeqStart
(lb1
),Ast.SeqStart
(lb2
)) -> return true
399 | (Ast.SeqEnd
(rb1
),Ast.SeqEnd
(rb2
)) -> return true
401 | (Ast.ExprStatement
(e1
,s1
),Ast.ExprStatement
(e2
,s2
)) ->
402 unify_expression e1 e2
403 | (Ast.IfHeader
(if1
,lp1
,e1
,rp1
),Ast.IfHeader
(if2
,lp2
,e2
,rp2
)) ->
404 unify_expression e1 e2
405 | (Ast.Else
(e1
),Ast.Else
(e2
)) -> return true
406 | (Ast.WhileHeader
(wh1
,lp1
,e1
,rp1
),Ast.WhileHeader
(wh2
,lp2
,e2
,rp2
)) ->
407 unify_expression e1 e2
408 | (Ast.DoHeader
(d1
),Ast.DoHeader
(d2
)) -> return true
409 | (Ast.WhileTail
(wh1
,lp1
,e1
,rp1
,s1
),Ast.WhileTail
(wh2
,lp2
,e2
,rp2
,s2
)) ->
410 unify_expression e1 e2
411 | (Ast.ForHeader
(fr1
,lp1
,e11
,s11
,e21
,s21
,e31
,rp1
),
412 Ast.ForHeader
(fr2
,lp2
,e12
,s12
,e22
,s22
,e32
,rp2
)) ->
414 (unify_option unify_expression e11 e12
)
416 (unify_option unify_expression e21 e22
)
417 (unify_option unify_expression e31 e32
))
418 | (Ast.IteratorHeader
(nm1
,lp1
,args1
,rp1
),
419 Ast.IteratorHeader
(nm2
,lp2
,args2
,rp2
)) ->
420 conjunct_bindings (unify_ident nm1 nm2
)
421 (unify_dots unify_expression edots args1 args2
)
422 | (Ast.DefineHeader
(_
,n1
,p1
),Ast.DefineHeader
(_
,n2
,p2
)) ->
423 conjunct_bindings (unify_ident n1 n2
)
424 (unify_define_parameters p1 p2
)
425 | (Ast.Break
(r1
,s1
),Ast.Break
(r2
,s2
)) -> return true
426 | (Ast.Continue
(r1
,s1
),Ast.Continue
(r2
,s2
)) -> return true
427 | (Ast.Label
(l1
,dd1
),Ast.Label
(l2
,dd2
)) -> unify_ident l1 l2
428 | (Ast.Goto
(g1
,l1
,dd1
),Ast.Goto
(g2
,l2
,dd2
)) -> unify_ident l1 l2
429 | (Ast.Return
(r1
,s1
),Ast.Return
(r2
,s2
)) -> return true
430 | (Ast.ReturnExpr
(r1
,e1
,s1
),Ast.ReturnExpr
(r2
,e2
,s2
)) ->
431 unify_expression e1 e2
433 | (Ast.DisjRuleElem
(res1
),_
) ->
434 disjunct_all_bindings
435 (List.map
(function x
-> unify_rule_elem x re2
) res1
)
436 | (_
,Ast.DisjRuleElem
(res2
)) ->
437 disjunct_all_bindings
438 (List.map
(function x
-> unify_rule_elem re1 x
) res2
)
440 | (Ast.MetaRuleElem
(_
,_
,_
),_
)
441 | (Ast.MetaStmt
(_
,_
,_
,_
),_
)
442 | (Ast.MetaStmtList
(_
,_
,_
),_
)
443 | (_
,Ast.MetaRuleElem
(_
,_
,_
))
444 | (_
,Ast.MetaStmt
(_
,_
,_
,_
))
445 | (_
,Ast.MetaStmtList
(_
,_
,_
)) -> return true
447 (* can match a rule_elem in different parts *)
448 | (Ast.Exp
(e1
),Ast.Exp
(e2
)) -> return true
449 | (Ast.Exp
(e1
),_
) -> subexp
(unify_expression e1
) re2
450 | (_
,Ast.Exp
(e2
)) -> subexp
(unify_expression e2
) re1
452 | (Ast.TopExp
(e1
),Ast.TopExp
(e2
)) -> unify_expression e1 e2
453 | (Ast.TopInit
(i1
),Ast.TopInit
(i2
)) -> unify_initialiser i1 i2
455 (* can match a rule_elem in different parts *)
456 | (Ast.Ty
(t1
),Ast.Ty
(t2
)) -> return true
457 | (Ast.Ty
(t1
),_
) -> subtype
(unify_fullType t1
) re2
458 | (_
,Ast.Ty
(t2
)) -> subtype
(unify_fullType t2
) re1
461 and unify_fninfo patterninfo cinfo
=
462 let patterninfo = List.sort compare
patterninfo in
463 let cinfo = List.sort compare
cinfo in
464 let rec loop = function
465 (Ast.FStorage
(sta
)::resta
,Ast.FStorage
(stb
)::restb
) ->
466 if unify_mcode sta stb
then loop (resta
,restb
) else return false
467 | (Ast.FType
(tya
)::resta
,Ast.FType
(tyb
)::restb
) ->
468 conjunct_bindings (unify_fullType tya tyb
) (loop (resta
,restb
))
469 | (Ast.FInline
(ia
)::resta
,Ast.FInline
(ib
)::restb
) ->
470 if unify_mcode ia ib
then loop (resta
,restb
) else return false
471 | (Ast.FAttr
(ia
)::resta
,Ast.FAttr
(ib
)::restb
) ->
472 if unify_mcode ia ib
then loop (resta
,restb
) else return false
473 | (x
::resta
,((y
::_
) as restb
)) ->
474 (match compare x y
with
476 | 1 -> loop (resta
,restb
)
477 | _
-> failwith
"not possible")
478 | _
-> return false in
479 loop (patterninfo,cinfo)
482 let bind = conjunct_bindings in
483 let option_default = return false in
484 let mcode r e
= option_default in
485 let expr r k e
= conjunct_bindings (f e
) (k e
) in
486 let donothing r k e
= k e
in
487 let recursor = V.combiner
bind option_default
488 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
490 donothing donothing donothing donothing
491 donothing expr donothing donothing donothing donothing donothing
492 donothing donothing donothing donothing donothing in
493 recursor.V.combiner_rule_elem
496 let bind = conjunct_bindings in
497 let option_default = return false in
498 let mcode r e
= option_default in
499 let fullType r k e
= conjunct_bindings (f e
) (k e
) in
500 let donothing r k e
= k e
in
501 let recursor = V.combiner
bind option_default
502 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
504 donothing donothing donothing donothing
505 donothing donothing fullType donothing donothing donothing donothing
506 donothing donothing donothing donothing donothing in
507 recursor.V.combiner_rule_elem
509 let rec unify_statement s1 s2
=
510 match (Ast.unwrap s1
,Ast.unwrap s2
) with
511 (Ast.Seq
(lb1
,d1
,s1
,rb1
),Ast.Seq
(lb2
,d2
,s2
,rb2
)) ->
512 conjunct_bindings (unify_rule_elem lb1 lb2
)
514 (unify_dots unify_statement sdots s1 s2
)
516 (unify_dots unify_statement sdots d1 d2
)
517 (unify_rule_elem rb1 rb2
)))
518 | (Ast.IfThen
(h1
,thn1
,_
),Ast.IfThen
(h2
,thn2
,_
)) ->
519 conjunct_bindings (unify_rule_elem h1 h2
) (unify_statement thn1 thn2
)
520 | (Ast.IfThenElse
(h1
,thn1
,e1
,els1
,_
),Ast.IfThenElse
(h2
,thn2
,e2
,els2
,_
)) ->
521 conjunct_bindings (unify_rule_elem h1 h2
)
522 (conjunct_bindings (unify_statement thn1 thn2
)
523 (conjunct_bindings (unify_rule_elem e1 e2
)
524 (unify_statement els1 els2
)))
525 | (Ast.While
(h1
,s1
,_
),Ast.While
(h2
,s2
,_
)) ->
526 conjunct_bindings (unify_rule_elem h1 h2
) (unify_statement s1 s2
)
527 | (Ast.Do
(h1
,s1
,t1
),Ast.Do
(h2
,s2
,t2
)) ->
528 conjunct_bindings (unify_rule_elem h1 h2
)
529 (conjunct_bindings (unify_statement s1 s2
) (unify_rule_elem t1 t2
))
530 | (Ast.For
(h1
,s1
,_
),Ast.For
(h2
,s2
,_
)) ->
531 conjunct_bindings (unify_rule_elem h1 h2
) (unify_statement s1 s2
)
532 | (Ast.Atomic
(re1
),Ast.Atomic
(re2
)) -> unify_rule_elem re1 re2
533 | (Ast.Disj
(s1
),_
) ->
534 let s2 = Ast.rewrap
s2 (Ast.DOTS
[s2]) in
535 disjunct_all_bindings
537 (function x
-> unify_dots unify_statement sdots x
s2)
539 | (_
,Ast.Disj
(s2)) ->
540 let s1 = Ast.rewrap
s1 (Ast.DOTS
[s1]) in
541 disjunct_all_bindings
543 (function x
-> unify_dots unify_statement sdots s1 x
)
545 | (Ast.Nest
(s1,_
,_
,_
,_
),Ast.Nest
(s2,_
,_
,_
,_
)) ->
546 unify_dots unify_statement sdots s1 s2
547 | (Ast.FunDecl
(h1
,lb1
,d1
,s1,rb1
),Ast.FunDecl
(h2
,lb2
,d2
,s2,rb2
)) ->
548 conjunct_bindings (unify_rule_elem h1 h2
)
549 (conjunct_bindings (unify_rule_elem lb1 lb2
)
550 (conjunct_bindings (unify_dots unify_statement sdots d1 d2
)
551 (conjunct_bindings (unify_dots unify_statement sdots s1 s2)
552 (unify_rule_elem rb1 rb2
))))
553 | (Ast.Define
(h1
,s1),Ast.Define
(h2
,s2)) ->
554 conjunct_bindings (unify_rule_elem h1 h2
)
555 (unify_dots unify_statement sdots s1 s2)
556 (* dots can match against anything. return true to be safe. *)
557 | (Ast.Dots
(_
,_
,_
,_
),_
) | (_
,Ast.Dots
(_
,_
,_
,_
))
558 | (Ast.Circles
(_
,_
,_
,_
),_
) | (_
,Ast.Circles
(_
,_
,_
,_
))
559 | (Ast.Stars
(_
,_
,_
,_
),_
) | (_
,Ast.Stars
(_
,_
,_
,_
)) -> return true
561 | (Ast.UniqueStm
(_
),_
)
563 | (_
,Ast.UniqueStm
(_
)) -> failwith
"unsupported statement"
566 let unify_statement_dots = unify_dots unify_statement sdots