parsing_cocci/unify_ast.ml

   1 (*
   2  * Copyright 2012, INRIA
   3  * Julia Lawall, Gilles Muller
   4  * Copyright 2010-2011, INRIA, University of Copenhagen
   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.
  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 "./unify_ast.ml"
  28 (* --------------------------------------------------------------------- *)
  29 (* Given two patterns, A and B, determine whether B can match any matched
  30 subterms of A.  For simplicity, this doesn't maintain an environment; it
  31 just assume metavariables match.  Thus the result is either NO or MAYBE. *)
  32
  33 module Ast = Ast_cocci
  34 module V = Visitor_ast
  35
  36 (* --------------------------------------------------------------------- *)
  37
  38 type res = NO | MAYBE
  39
  40 let return b = if b then MAYBE else NO
  41
  42 let unify_mcode (x,_,_,_) (y,_,_,_) = x = y
  43
  44 let ret_unify_mcode a b = return (unify_mcode a b)
  45
  46 let unify_option f t1 t2 =
  47   match (t1,t2) with
  48     (Some t1, Some t2) -> f t1 t2
  49   | (None, None) -> return true
  50   | _ -> return false
  51
  52 let unify_true_option f t1 t2 =
  53   match (t1,t2) with
  54     (Some t1, Some t2) -> f t1 t2
  55   | (None, None) -> return true
  56   | _ -> return true
  57
  58 let bool_unify_option f t1 t2 =
  59   match (t1,t2) with
  60     (Some t1, Some t2) -> f t1 t2
  61   | (None, None) -> true
  62   | _ -> false
  63
  64 let conjunct_bindings b1 b2 =
  65   match b1 with NO -> b1 | MAYBE -> b2
  66
  67 let disjunct_bindings b1 b2 =
  68   match b1 with MAYBE -> b1 | NO -> b2
  69
  70 let disjunct_all_bindings = List.fold_left disjunct_bindings NO
  71
  72 (* --------------------------------------------------------------------- *)
  73
  74 (* compute the common prefix.  if in at least one case, this ends with the
  75 end of the pattern or a ..., then return true. *)
  76
  77 let unify_lists fn dfn la lb =
  78   let rec loop = function
  79       ([],_) | (_,[]) -> return true
  80     | (cura::resta,curb::restb) ->
  81         (match fn cura curb with
  82           MAYBE -> loop (resta,restb)
  83         | NO -> if dfn cura or dfn curb then MAYBE else NO) in
  84   loop (la,lb)
  85
  86 let unify_dots fn dfn d1 d2 =
  87   match (Ast.unwrap d1,Ast.unwrap d2) with
  88     (Ast.DOTS(l1),Ast.DOTS(l2))
  89   | (Ast.CIRCLES(l1),Ast.CIRCLES(l2))
  90   | (Ast.STARS(l1),Ast.STARS(l2)) -> unify_lists fn dfn l1 l2
  91   | _ -> return false
  92
  93 let edots e =
  94   match Ast.unwrap e with
  95     Ast.Edots(_,_) | Ast.Ecircles(_,_) | Ast.Estars(_,_) -> true
  96   | _ -> false
  97
  98 let ddots e =
  99   match Ast.unwrap e with
 100     Ast.Ddots(_,_) -> true
 101   | _ -> false
 102
 103 let pdots p =
 104   match Ast.unwrap p with
 105     Ast.Pdots(_) | Ast.Pcircles(_) -> true
 106   | _ -> false
 107
 108 let dpdots e =
 109   match Ast.unwrap e with
 110     Ast.DPdots(_) | Ast.DPcircles(_) -> true
 111   | _ -> false
 112
 113 let sdots s =
 114   match Ast.unwrap s with
 115     Ast.Dots(_,_,_,_) | Ast.Circles(_,_,_,_) | Ast.Stars(_,_,_,_) -> true
 116   | _ -> false
 117
 118 let idots e =
 119   match Ast.unwrap e with
 120     Ast.Idots(_,_) -> true
 121   | _ -> false
 122
 123 (* --------------------------------------------------------------------- *)
 124 (* Identifier *)
 125
 126 let rec unify_ident i1 i2 =
 127   match (Ast.unwrap i1,Ast.unwrap i2) with
 128     (Ast.Id(i1),Ast.Id(i2)) -> return (unify_mcode i1 i2)
 129
 130   | (Ast.MetaId(_,_,_,_),_)
 131   | (Ast.MetaFunc(_,_,_,_),_)
 132   | (Ast.MetaLocalFunc(_,_,_,_),_)
 133   | (_,Ast.MetaId(_,_,_,_))
 134   | (_,Ast.MetaFunc(_,_,_,_))
 135   | (_,Ast.MetaLocalFunc(_,_,_,_)) -> return true
 136
 137   | (Ast.AsIdent(id1,asid1),_) ->
 138       disjunct_all_bindings
 139         (List.map (function x -> unify_ident x i2) [id1;asid1])
 140   | (_,Ast.AsIdent(id2,asid2)) ->
 141       disjunct_all_bindings
 142         (List.map (function x -> unify_ident x i1) [id2;asid2])
 143
 144   | (Ast.DisjId(i1),_) ->
 145       disjunct_all_bindings (List.map (function x -> unify_ident x i2) i1)
 146   | (_,Ast.DisjId(i2)) ->
 147       disjunct_all_bindings (List.map (function x -> unify_ident i1 x) i2)
 148
 149   | (Ast.OptIdent(_),_)
 150   | (Ast.UniqueIdent(_),_)
 151   | (_,Ast.OptIdent(_))
 152   | (_,Ast.UniqueIdent(_)) -> failwith "unsupported ident"
 153
 154 (* --------------------------------------------------------------------- *)
 155 (* Expression *)
 156
 157 and unify_expression e1 e2 =
 158   match (Ast.unwrap e1,Ast.unwrap e2) with
 159     (Ast.Ident(i1),Ast.Ident(i2)) -> unify_ident i1 i2
 160   | (Ast.Constant(c1),Ast.Constant(c2))-> return (unify_mcode c1 c2)
 161   | (Ast.FunCall(f1,lp1,args1,rp1),Ast.FunCall(f2,lp2,args2,rp2)) ->
 162       conjunct_bindings
 163         (unify_expression f1 f2)
 164         (unify_dots unify_expression edots args1 args2)
 165   | (Ast.Assignment(l1,op1,r1,_),Ast.Assignment(l2,op2,r2,_)) ->
 166       if unify_mcode op1 op2
 167       then conjunct_bindings (unify_expression l1 l2) (unify_expression r1 r2)
 168       else return false
 169   | (Ast.Sequence(l1,_,r1),Ast.Sequence(l2,_,r2)) ->
 170       conjunct_bindings (unify_expression l1 l2) (unify_expression r1 r2)
 171   | (Ast.CondExpr(tst1,q1,thn1,c1,els1),Ast.CondExpr(tst2,q2,thn2,c2,els2)) ->
 172       conjunct_bindings (unify_expression tst1 tst2)
 173         (conjunct_bindings (unify_option unify_expression thn1 thn2)
 174            (unify_expression els1 els2))
 175   | (Ast.Postfix(e1,op1),Ast.Postfix(e2,op2)) ->
 176       if unify_mcode op1 op2 then unify_expression e1 e2 else return false
 177   | (Ast.Infix(e1,op1),Ast.Infix(e2,op2)) ->
 178       if unify_mcode op1 op2 then unify_expression e1 e2 else return false
 179   | (Ast.Unary(e1,op1),Ast.Unary(e2,op2)) ->
 180       if unify_mcode op1 op2 then unify_expression e1 e2 else return false
 181   | (Ast.Binary(l1,op1,r1),Ast.Binary(l2,op2,r2)) ->
 182       if unify_mcode op1 op2
 183       then conjunct_bindings (unify_expression l1 l2) (unify_expression r1 r2)
 184       else return false
 185   | (Ast.ArrayAccess(ar1,lb1,e1,rb1),Ast.ArrayAccess(ar2,lb2,e2,rb2)) ->
 186       conjunct_bindings (unify_expression ar1 ar2) (unify_expression e1 e2)
 187   | (Ast.RecordAccess(e1,d1,fld1),Ast.RecordAccess(e2,d2,fld2)) ->
 188       conjunct_bindings (unify_expression e1 e2) (unify_ident fld1 fld2)
 189   | (Ast.RecordPtAccess(e1,pt1,fld1),Ast.RecordPtAccess(e2,pt2,fld2)) ->
 190       conjunct_bindings (unify_expression e1 e2) (unify_ident fld1 fld2)
 191   | (Ast.Cast(lp1,ty1,rp1,e1),Ast.Cast(lp2,ty2,rp2,e2)) ->
 192       conjunct_bindings (unify_fullType ty1 ty2) (unify_expression e1 e2)
 193   | (Ast.SizeOfExpr(szf1,e1),Ast.SizeOfExpr(szf2,e2)) ->
 194       unify_expression e1 e2
 195   | (Ast.SizeOfType(szf1,lp1,ty1,rp1),Ast.SizeOfType(szf2,lp2,ty2,rp2)) ->
 196       unify_fullType ty1 ty2
 197   | (Ast.TypeExp(ty1),Ast.TypeExp(ty2)) -> unify_fullType ty1 ty2
 198   | (Ast.Constructor(lp1,ty1,rp1,i1),Ast.Constructor(lp2,ty2,rp2,i2)) ->
 199       conjunct_bindings (unify_fullType ty1 ty2) (unify_initialiser i1 i2)
 200   | (Ast.Paren(lp1,e1,rp1),Ast.Paren(lp2,e2,rp2)) ->
 201       unify_expression e1 e2
 202
 203   | (Ast.MetaErr(_,_,_,_),_)
 204   | (Ast.MetaExpr(_,_,_,_,_,_),_)
 205   | (Ast.MetaExprList(_,_,_,_),_)
 206   | (_,Ast.MetaErr(_,_,_,_))
 207   | (_,Ast.MetaExpr(_,_,_,_,_,_))
 208   | (_,Ast.MetaExprList(_,_,_,_)) -> return true
 209
 210   | (Ast.AsExpr(exp1,asexp1),_) ->
 211       disjunct_all_bindings
 212         (List.map (function x -> unify_expression x e2) [exp1;asexp1])
 213   | (_,Ast.AsExpr(exp2,asexp2)) ->
 214       disjunct_all_bindings
 215         (List.map (function x -> unify_expression x e1) [exp2;asexp2])
 216
 217   | (Ast.EComma(cm1),Ast.EComma(cm2)) -> return true
 218
 219   | (Ast.DisjExpr(e1),_) ->
 220       disjunct_all_bindings (List.map (function x -> unify_expression x e2) e1)
 221   | (_,Ast.DisjExpr(e2)) ->
 222       disjunct_all_bindings (List.map (function x -> unify_expression e1 x) e2)
 223   | (Ast.NestExpr(_,e1,_,_,_),Ast.NestExpr(_,e2,_,_,_)) ->
 224       unify_dots unify_expression edots e1 e2
 225
 226   (* dots can match against anything.  return true to be safe. *)
 227   | (Ast.Edots(_,_),_) | (_,Ast.Edots(_,_))
 228   | (Ast.Ecircles(_,_),_) | (_,Ast.Ecircles(_,_))
 229   | (Ast.Estars(_,_),_) | (_,Ast.Estars(_,_)) -> return true
 230
 231   | (Ast.OptExp(_),_)
 232   | (Ast.UniqueExp(_),_)
 233   | (_,Ast.OptExp(_))
 234   | (_,Ast.UniqueExp(_)) -> failwith "unsupported expression"
 235   | _ -> return false
 236
 237 (* --------------------------------------------------------------------- *)
 238 (* Types *)
 239
 240 and unify_fullType ft1 ft2 =
 241   match (Ast.unwrap ft1,Ast.unwrap ft2) with
 242     (Ast.Type(_,cv1,ty1),Ast.Type(_,cv2,ty2)) ->
 243       if bool_unify_option unify_mcode cv1 cv2
 244       then unify_typeC ty1 ty2
 245       else return false
 246   | (Ast.AsType(ty1,asty1),_) ->
 247       disjunct_all_bindings
 248         (List.map (function x -> unify_fullType x ft2) [ty1;asty1])
 249   | (_,Ast.AsType(ty2,asty2)) ->
 250       disjunct_all_bindings
 251         (List.map (function x -> unify_fullType x ft1) [ty2;asty2])
 252   | (Ast.DisjType(ft1),_) ->
 253       disjunct_all_bindings (List.map (function x -> unify_fullType x ft2) ft1)
 254   | (_,Ast.DisjType(ft2)) ->
 255       disjunct_all_bindings (List.map (function x -> unify_fullType ft1 x) ft2)
 256
 257   | (Ast.OptType(_),_)
 258   | (Ast.UniqueType(_),_)
 259   | (_,Ast.OptType(_))
 260   | (_,Ast.UniqueType(_)) -> failwith "unsupported type"
 261
 262 and unify_typeC t1 t2 =
 263   match (Ast.unwrap t1,Ast.unwrap t2) with
 264     (Ast.BaseType(ty1,stringsa),Ast.BaseType(ty2,stringsb)) ->
 265       if ty1 = ty2
 266       then
 267         unify_lists ret_unify_mcode (function _ -> false (* not dots*))
 268           stringsa stringsb
 269       else return false
 270   | (Ast.SignedT(sgn1,ty1),Ast.SignedT(sgn2,ty2)) ->
 271       if unify_mcode sgn1 sgn2
 272       then unify_option unify_typeC ty1 ty2
 273       else return false
 274   | (Ast.Pointer(ty1,s1),Ast.Pointer(ty2,s2)) -> unify_fullType ty1 ty2
 275   | (Ast.FunctionPointer(tya,lp1a,stara,rp1a,lp2a,paramsa,rp2a),
 276      Ast.FunctionPointer(tyb,lp1b,starb,rp1b,lp2b,paramsb,rp2b)) ->
 277        if List.for_all2 unify_mcode
 278            [lp1a;stara;rp1a;lp2a;rp2a] [lp1b;starb;rp1b;lp2b;rp2b]
 279        then
 280          conjunct_bindings (unify_fullType tya tyb)
 281            (unify_dots unify_parameterTypeDef pdots paramsa paramsb)
 282        else return false
 283   | (Ast.FunctionType(_,tya,lp1a,paramsa,rp1a),
 284      Ast.FunctionType(_,tyb,lp1b,paramsb,rp1b)) ->
 285        if List.for_all2 unify_mcode [lp1a;rp1a] [lp1b;rp1b]
 286        then
 287          conjunct_bindings (unify_option unify_fullType tya tyb)
 288            (unify_dots unify_parameterTypeDef pdots paramsa paramsb)
 289        else return false
 290   | (Ast.FunctionType _ , _) -> failwith "not supported"
 291   | (Ast.Array(ty1,lb1,e1,rb1),Ast.Array(ty2,lb2,e2,rb2)) ->
 292       conjunct_bindings
 293         (unify_fullType ty1 ty2) (unify_option unify_expression e1 e2)
 294   | (Ast.EnumName(s1,Some ts1),Ast.EnumName(s2,Some ts2)) ->
 295       if unify_mcode s1 s2 then unify_ident ts1 ts2 else return false
 296   | (Ast.EnumName(s1,None),Ast.EnumName(s2,None)) ->
 297       return true
 298   | (Ast.EnumDef(ty1,lb1,ids1,rb1),Ast.EnumDef(ty2,lb2,ids2,rb2)) ->
 299        conjunct_bindings (unify_fullType ty1 ty2)
 300          (unify_dots unify_expression edots ids1 ids2)
 301   | (Ast.StructUnionName(s1,Some ts1),Ast.StructUnionName(s2,Some ts2)) ->
 302       if unify_mcode s1 s2 then unify_ident ts1 ts2 else return false
 303   | (Ast.StructUnionName(s1,None),Ast.StructUnionName(s2,None)) ->
 304       return (unify_mcode s1 s2)
 305   | (Ast.StructUnionDef(ty1,lb1,decls1,rb1),
 306      Ast.StructUnionDef(ty2,lb2,decls2,rb2)) ->
 307        conjunct_bindings (unify_fullType ty1 ty2)
 308          (unify_dots unify_declaration ddots decls1 decls2)
 309   | (Ast.TypeName(t1),Ast.TypeName(t2)) -> return (unify_mcode t1 t2)
 310
 311   | (Ast.MetaType(_,_,_),_)
 312   | (_,Ast.MetaType(_,_,_)) -> return true
 313   | _ -> return false
 314
 315 (* --------------------------------------------------------------------- *)
 316 (* Variable declaration *)
 317 (* Even if the Cocci program specifies a list of declarations, they are
 318    split out into multiple declarations of a single variable each. *)
 319
 320 and unify_declaration d1 d2 =
 321   match (Ast.unwrap d1,Ast.unwrap d2) with
 322     (Ast.MetaDecl(_,_,_),_) | (_,Ast.MetaDecl(_,_,_)) -> return true
 323   | (Ast.MetaField(_,_,_),_) | (_,Ast.MetaField(_,_,_)) -> return true
 324   | (Ast.MetaFieldList(_,_,_,_),_) | (_,Ast.MetaFieldList(_,_,_,_)) ->
 325       return true
 326   | (Ast.Init(stg1,ft1,id1,eq1,i1,s1),Ast.Init(stg2,ft2,id2,eq2,i2,s2)) ->
 327       if bool_unify_option unify_mcode stg1 stg2
 328       then
 329         conjunct_bindings (unify_fullType ft1 ft2)
 330           (conjunct_bindings (unify_ident id1 id2) (unify_initialiser i1 i2))
 331       else return false
 332   | (Ast.UnInit(stg1,ft1,id1,s1),Ast.UnInit(stg2,ft2,id2,s2)) ->
 333       if bool_unify_option unify_mcode stg1 stg2
 334       then conjunct_bindings (unify_fullType ft1 ft2) (unify_ident id1 id2)
 335       else return false
 336   | (Ast.MacroDecl(n1,lp1,args1,rp1,sem1),
 337      Ast.MacroDecl(n2,lp2,args2,rp2,sem2)) ->
 338        conjunct_bindings (unify_ident n1 n2)
 339          (unify_dots unify_expression edots args1 args2)
 340   | (Ast.MacroDeclInit(n1,lp1,args1,rp1,eq1,ini1,sem1),
 341      Ast.MacroDeclInit(n2,lp2,args2,rp2,eq2,ini2,sem2)) ->
 342        conjunct_bindings (unify_ident n1 n2)
 343          (conjunct_bindings (unify_dots unify_expression edots args1 args2)
 344             (unify_initialiser ini1 ini2))
 345   | (Ast.TyDecl(ft1,s1),Ast.TyDecl(ft2,s2)) -> unify_fullType ft1 ft2
 346   | (Ast.Typedef(stg1,ft1,id1,s1),Ast.Typedef(stg2,ft2,id2,s2)) ->
 347       conjunct_bindings (unify_fullType ft1 ft2) (unify_typeC id1 id2)
 348   | (Ast.DisjDecl(d1),_) ->
 349       disjunct_all_bindings
 350         (List.map (function x -> unify_declaration x d2) d1)
 351   | (_,Ast.DisjDecl(d2)) ->
 352       disjunct_all_bindings
 353         (List.map (function x -> unify_declaration d1 x) d2)
 354   (* dots can match against anything.  return true to be safe. *)
 355   | (Ast.Ddots(_,_),_) | (_,Ast.Ddots(_,_)) -> return true
 356
 357   | (Ast.OptDecl(_),_)
 358   | (Ast.UniqueDecl(_),_)
 359   | (_,Ast.OptDecl(_))
 360   | (_,Ast.UniqueDecl(_)) -> failwith "unsupported decl"
 361   | _ -> return false
 362
 363 (* --------------------------------------------------------------------- *)
 364 (* Initializer *)
 365
 366 and unify_initialiser i1 i2 =
 367   match (Ast.unwrap i1,Ast.unwrap i2) with
 368     (Ast.MetaInit(_,_,_),_) | (_,Ast.MetaInit(_,_,_)) -> return true
 369   | (Ast.MetaInitList(_,_,_,_),_) | (_,Ast.MetaInitList(_,_,_,_)) -> return true
 370   | (Ast.InitExpr(expa),Ast.InitExpr(expb)) ->
 371       unify_expression expa expb
 372   | (Ast.ArInitList(_,initlista,_),
 373      Ast.ArInitList(_,initlistb,_)) ->
 374       (* ignore whencode - returns true safely *)
 375       unify_dots unify_initialiser idots initlista initlistb
 376   | (Ast.StrInitList(_,_,initlista,_,whena),
 377      Ast.StrInitList(_,_,initlistb,_,whenb)) ->
 378       (* ignore whencode - returns true safely *)
 379       unify_lists unify_initialiser (function _ -> false) initlista initlistb
 380   | (Ast.InitGccExt(designatorsa,_,inia),
 381      Ast.InitGccExt(designatorsb,_,inib)) ->
 382        conjunct_bindings
 383          (unify_lists unify_designator (function _ -> false)
 384             designatorsa designatorsb)
 385          (unify_initialiser inia inib)
 386   | (Ast.InitGccName(namea,_,inia),Ast.InitGccName(nameb,_,inib)) ->
 387       conjunct_bindings (unify_ident namea nameb) (unify_initialiser inia inib)
 388
 389   | (Ast.OptIni(_),_)
 390   | (Ast.UniqueIni(_),_)
 391   | (_,Ast.OptIni(_))
 392   | (_,Ast.UniqueIni(_)) -> failwith "unsupported decl"
 393   | _ -> return false
 394
 395 and unify_designator d1 d2 =
 396   match (d1,d2) with
 397     (Ast.DesignatorField(_,idb),Ast.DesignatorField(_,ida)) ->
 398       unify_ident ida idb
 399   | (Ast.DesignatorIndex(_,expa,_),Ast.DesignatorIndex(_,expb,_)) ->
 400       unify_expression expa expb
 401   | (Ast.DesignatorRange(_,mina,_,maxa,_),
 402      Ast.DesignatorRange(_,minb,_,maxb,_)) ->
 403        conjunct_bindings (unify_expression mina minb)
 404          (unify_expression maxa maxb)
 405   | _ -> return false
 406
 407 (* --------------------------------------------------------------------- *)
 408 (* Parameter *)
 409
 410 and unify_parameterTypeDef p1 p2 =
 411   match (Ast.unwrap p1,Ast.unwrap p2) with
 412     (Ast.VoidParam(ft1),Ast.VoidParam(ft2)) -> unify_fullType ft1 ft2
 413   | (Ast.Param(ft1,i1),Ast.Param(ft2,i2)) ->
 414       conjunct_bindings (unify_fullType ft1 ft2)
 415         (unify_option unify_ident i1 i2)
 416
 417   | (Ast.MetaParam(_,_,_),_)
 418   | (Ast.MetaParamList(_,_,_,_),_)
 419   | (_,Ast.MetaParam(_,_,_))
 420   | (_,Ast.MetaParamList(_,_,_,_)) -> return true
 421
 422   | (Ast.PComma(_),Ast.PComma(_)) -> return true
 423
 424   (* dots can match against anything.  return true to be safe. *)
 425   | (Ast.Pdots(_),_) | (_,Ast.Pdots(_))
 426   | (Ast.Pcircles(_),_) | (_,Ast.Pcircles(_)) -> return true
 427
 428   | (Ast.OptParam(_),_)
 429   | (Ast.UniqueParam(_),_)
 430   | (_,Ast.OptParam(_))
 431   | (_,Ast.UniqueParam(_)) -> failwith "unsupported parameter"
 432   | _ -> return false
 433
 434 (* --------------------------------------------------------------------- *)
 435 (* Define parameter *)
 436
 437 and unify_define_parameters p1 p2 =
 438  match (Ast.unwrap p1,Ast.unwrap p2) with
 439     (Ast.NoParams,Ast.NoParams) -> return true
 440   | (Ast.DParams(lp1,params1,rp1),Ast.DParams(lp2,params2,rp2)) ->
 441       unify_dots unify_define_param dpdots params1 params2
 442   | _ -> return false
 443
 444 and unify_define_param p1 p2 =
 445   match (Ast.unwrap p1,Ast.unwrap p2) with
 446     (Ast.DParam(i1),Ast.DParam(i2)) ->
 447         (unify_ident i1 i2)
 448   | (Ast.DPComma(_),Ast.DPComma(_)) -> return true
 449
 450   (* dots can match against anything.  return true to be safe. *)
 451   | (Ast.DPdots(_),_) | (_,Ast.DPdots(_))
 452   | (Ast.DPcircles(_),_) | (_,Ast.DPcircles(_)) -> return true
 453
 454   | (Ast.OptDParam(_),_)
 455   | (Ast.UniqueDParam(_),_)
 456   | (_,Ast.OptDParam(_))
 457   | (_,Ast.UniqueDParam(_)) -> failwith "unsupported parameter"
 458   | _ -> return false
 459
 460 (* --------------------------------------------------------------------- *)
 461 (* Top-level code *)
 462
 463 and unify_rule_elem re1 re2 =
 464   match (Ast.unwrap re1,Ast.unwrap re2) with
 465     (Ast.FunHeader(_,_,fi1,nm1,lp1,params1,rp1),
 466      Ast.FunHeader(_,_,fi2,nm2,lp2,params2,rp2)) ->
 467        conjunct_bindings (unify_fninfo fi1 fi2)
 468          (conjunct_bindings (unify_ident nm1 nm2)
 469             (unify_dots unify_parameterTypeDef pdots params1 params2))
 470   | (Ast.Decl(_,_,d1),Ast.Decl(_,_,d2)) -> unify_declaration d1 d2
 471
 472   | (Ast.SeqStart(lb1),Ast.SeqStart(lb2)) -> return true
 473   | (Ast.SeqEnd(rb1),Ast.SeqEnd(rb2)) -> return true
 474
 475   | (Ast.ExprStatement(e1,s1),Ast.ExprStatement(e2,s2)) ->
 476       unify_option unify_expression e1 e2
 477   | (Ast.IfHeader(if1,lp1,e1,rp1),Ast.IfHeader(if2,lp2,e2,rp2)) ->
 478       unify_expression e1 e2
 479   | (Ast.Else(e1),Ast.Else(e2)) -> return true
 480   | (Ast.WhileHeader(wh1,lp1,e1,rp1),Ast.WhileHeader(wh2,lp2,e2,rp2)) ->
 481       unify_expression e1 e2
 482   | (Ast.DoHeader(d1),Ast.DoHeader(d2)) -> return true
 483   | (Ast.WhileTail(wh1,lp1,e1,rp1,s1),Ast.WhileTail(wh2,lp2,e2,rp2,s2)) ->
 484       unify_expression e1 e2
 485   | (Ast.ForHeader(fr1,lp1,first1,e21,s21,e31,rp1),
 486      Ast.ForHeader(fr2,lp2,first2,e22,s22,e32,rp2)) ->
 487        let first =
 488          match (first1,first2) with
 489            (Ast.ForExp(e11,s11),Ast.ForExp(e12,s1)) ->
 490              unify_option unify_expression e11 e12
 491          | (Ast.ForDecl(_,_,d1),Ast.ForDecl(_,_,d2)) ->
 492              unify_declaration d1 d2
 493          | _ -> return false in
 494        conjunct_bindings first
 495          (conjunct_bindings
 496             (unify_option unify_expression e21 e22)
 497             (unify_option unify_expression e31 e32))
 498   | (Ast.IteratorHeader(nm1,lp1,args1,rp1),
 499      Ast.IteratorHeader(nm2,lp2,args2,rp2)) ->
 500       conjunct_bindings (unify_ident nm1 nm2)
 501          (unify_dots unify_expression edots args1 args2)
 502   | (Ast.Undef(_,n1),Ast.Undef(_,n2)) -> unify_ident n1 n2
 503   | (Ast.DefineHeader(_,n1,p1),Ast.DefineHeader(_,n2,p2)) ->
 504       conjunct_bindings (unify_ident n1 n2)
 505         (unify_define_parameters p1 p2)
 506   | (Ast.Break(r1,s1),Ast.Break(r2,s2)) -> return true
 507   | (Ast.Continue(r1,s1),Ast.Continue(r2,s2)) -> return true
 508   | (Ast.Label(l1,dd1),Ast.Label(l2,dd2)) -> unify_ident l1 l2
 509   | (Ast.Goto(g1,l1,dd1),Ast.Goto(g2,l2,dd2)) -> unify_ident l1 l2
 510   | (Ast.Return(r1,s1),Ast.Return(r2,s2)) -> return true
 511   | (Ast.ReturnExpr(r1,e1,s1),Ast.ReturnExpr(r2,e2,s2)) ->
 512       unify_expression e1 e2
 513
 514   | (Ast.DisjRuleElem(res1),_) ->
 515       disjunct_all_bindings
 516         (List.map (function x -> unify_rule_elem x re2) res1)
 517   | (_,Ast.DisjRuleElem(res2)) ->
 518       disjunct_all_bindings
 519         (List.map (function x -> unify_rule_elem re1 x) res2)
 520
 521   | (Ast.MetaRuleElem(_,_,_),_)
 522   | (Ast.MetaStmt(_,_,_,_),_)
 523   | (Ast.MetaStmtList(_,_,_),_)
 524   | (_,Ast.MetaRuleElem(_,_,_))
 525   | (_,Ast.MetaStmt(_,_,_,_))
 526   | (_,Ast.MetaStmtList(_,_,_)) -> return true
 527
 528     (* can match a rule_elem in different parts *)
 529   | (Ast.Exp(e1),Ast.Exp(e2)) -> return true
 530   | (Ast.Exp(e1),_) -> subexp (unify_expression e1) re2
 531   | (_,Ast.Exp(e2)) -> subexp (unify_expression e2) re1
 532
 533   | (Ast.TopExp(e1),Ast.TopExp(e2)) -> unify_expression e1 e2
 534   | (Ast.TopInit(i1),Ast.TopInit(i2)) -> unify_initialiser i1 i2
 535
 536     (* can match a rule_elem in different parts *)
 537   | (Ast.Ty(t1),Ast.Ty(t2)) -> return true
 538   | (Ast.Ty(t1),_) -> subtype (unify_fullType t1) re2
 539   | (_,Ast.Ty(t2)) -> subtype (unify_fullType t2) re1
 540   | _ -> return false
 541
 542 and unify_fninfo patterninfo cinfo =
 543   let patterninfo = List.sort compare patterninfo in
 544   let cinfo = List.sort compare cinfo in
 545   let rec loop = function
 546       (Ast.FStorage(sta)::resta,Ast.FStorage(stb)::restb) ->
 547       if unify_mcode sta stb then loop (resta,restb) else return false
 548     | (Ast.FType(tya)::resta,Ast.FType(tyb)::restb) ->
 549         conjunct_bindings (unify_fullType tya tyb) (loop (resta,restb))
 550     | (Ast.FInline(ia)::resta,Ast.FInline(ib)::restb) ->
 551         if unify_mcode ia ib then loop (resta,restb) else return false
 552     | (Ast.FAttr(ia)::resta,Ast.FAttr(ib)::restb) ->
 553         if unify_mcode ia ib then loop (resta,restb) else return false
 554     | (x::resta,((y::_) as restb)) ->
 555         (match compare x y with
 556           -1 -> return false
 557         | 1 -> loop (resta,restb)
 558         | _ -> failwith "not possible")
 559     | _ -> return false in
 560   loop (patterninfo,cinfo)
 561
 562 and subexp f =
 563   let bind = conjunct_bindings in
 564   let option_default = return false in
 565   let mcode r e = option_default in
 566   let expr r k e = conjunct_bindings (f e) (k e) in
 567   let donothing r k e = k e in
 568   let recursor = V.combiner bind option_default
 569       mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 570       donothing donothing donothing donothing donothing
 571       donothing expr donothing donothing donothing donothing donothing
 572       donothing donothing donothing donothing donothing in
 573   recursor.V.combiner_rule_elem
 574
 575 and subtype f =
 576   let bind = conjunct_bindings in
 577   let option_default = return false in
 578   let mcode r e = option_default in
 579   let fullType r k e = conjunct_bindings (f e) (k e) in
 580   let donothing r k e = k e in
 581   let recursor = V.combiner bind option_default
 582       mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 583       donothing donothing donothing donothing donothing
 584       donothing donothing fullType donothing donothing donothing donothing
 585       donothing donothing donothing donothing donothing in
 586   recursor.V.combiner_rule_elem
 587
 588 let rec unify_statement s1 s2 =
 589   match (Ast.unwrap s1,Ast.unwrap s2) with
 590     (Ast.Seq(lb1,s1,rb1),Ast.Seq(lb2,s2,rb2)) ->
 591       conjunct_bindings (unify_rule_elem lb1 lb2)
 592         (conjunct_bindings
 593            (unify_dots unify_statement sdots s1 s2)
 594            (unify_rule_elem rb1 rb2))
 595   | (Ast.IfThen(h1,thn1,_),Ast.IfThen(h2,thn2,_)) ->
 596       conjunct_bindings (unify_rule_elem h1 h2) (unify_statement thn1 thn2)
 597   | (Ast.IfThenElse(h1,thn1,e1,els1,_),Ast.IfThenElse(h2,thn2,e2,els2,_)) ->
 598       conjunct_bindings (unify_rule_elem h1 h2)
 599         (conjunct_bindings (unify_statement thn1 thn2)
 600            (conjunct_bindings (unify_rule_elem e1 e2)
 601               (unify_statement els1 els2)))
 602   | (Ast.While(h1,s1,_),Ast.While(h2,s2,_)) ->
 603       conjunct_bindings (unify_rule_elem h1 h2) (unify_statement s1 s2)
 604   | (Ast.Do(h1,s1,t1),Ast.Do(h2,s2,t2)) ->
 605       conjunct_bindings (unify_rule_elem h1 h2)
 606         (conjunct_bindings (unify_statement s1 s2) (unify_rule_elem t1 t2))
 607   | (Ast.For(h1,s1,_),Ast.For(h2,s2,_)) ->
 608       conjunct_bindings (unify_rule_elem h1 h2) (unify_statement s1 s2)
 609   | (Ast.Atomic(re1),Ast.Atomic(re2)) -> unify_rule_elem re1 re2
 610   | (Ast.Disj(s1),_) ->
 611       let s2 = Ast.rewrap s2 (Ast.DOTS[s2]) in
 612       disjunct_all_bindings
 613         (List.map
 614            (function x -> unify_dots unify_statement sdots x s2)
 615            s1)
 616   | (_,Ast.Disj(s2)) ->
 617       let s1 = Ast.rewrap s1 (Ast.DOTS[s1]) in
 618       disjunct_all_bindings
 619         (List.map
 620            (function x -> unify_dots unify_statement sdots s1 x)
 621            s2)
 622   | (Ast.Nest(_,s1,_,_,_,_,_),Ast.Nest(_,s2,_,_,_,_,_)) ->
 623       unify_dots unify_statement sdots s1 s2
 624   | (Ast.FunDecl(h1,lb1,s1,rb1),Ast.FunDecl(h2,lb2,s2,rb2)) ->
 625       conjunct_bindings (unify_rule_elem h1 h2)
 626         (conjunct_bindings (unify_rule_elem lb1 lb2)
 627            (conjunct_bindings (unify_dots unify_statement sdots s1 s2)
 628               (unify_rule_elem rb1 rb2)))
 629   | (Ast.Define(h1,s1),Ast.Define(h2,s2)) ->
 630       conjunct_bindings (unify_rule_elem h1 h2)
 631         (unify_dots unify_statement sdots s1 s2)
 632   (* dots can match against anything.  return true to be safe. *)
 633   | (Ast.Dots(_,_,_,_),_) | (_,Ast.Dots(_,_,_,_))
 634   | (Ast.Circles(_,_,_,_),_) | (_,Ast.Circles(_,_,_,_))
 635   | (Ast.Stars(_,_,_,_),_) | (_,Ast.Stars(_,_,_,_)) -> return true
 636   | (Ast.OptStm(_),_)
 637   | (Ast.UniqueStm(_),_)
 638   | (_,Ast.OptStm(_))
 639   | (_,Ast.UniqueStm(_)) -> failwith "unsupported statement"
 640   | _ -> return false
 641
 642 let unify_statement_dots = unify_dots unify_statement sdots