parsing_cocci/disjdistr.ml

   1 module Ast = Ast_cocci
   2 module V = Visitor_ast
   3
   4 let setify l = (* keep first *)
   5   let rec loop seen = function
   6       [] -> []
   7     | x::xs ->
   8         if List.mem x seen then loop seen xs else x::(loop (x::seen) xs) in
   9   loop [] l
  10
  11 let disjmult2 e1 e2 k =
  12   List.concat
  13     (List.map (function e1 -> List.map (function e2 -> k e1 e2) e2) e1)
  14
  15 let disjmult3 e1 e2 e3 k =
  16   List.concat
  17     (List.map
  18        (function e1 ->
  19          List.concat
  20            (List.map
  21               (function e2 -> List.map (function e3 -> k e1 e2 e3) e3)
  22               e2))
  23        e1)
  24
  25 let rec disjmult f = function
  26     [] -> [[]]
  27   | x::xs ->
  28       let cur = f x in
  29       let rest = disjmult f xs in
  30       disjmult2 cur rest (function cur -> function rest -> cur :: rest)
  31
  32 let disjoption f = function
  33     None -> [None]
  34   | Some x -> List.map (function x -> Some x) (f x)
  35
  36 let disjdots f d =
  37   match Ast.unwrap d with
  38     Ast.DOTS(l) ->
  39       List.map (function l -> Ast.rewrap d (Ast.DOTS(l))) (disjmult f l)
  40   | Ast.CIRCLES(l) ->
  41       List.map (function l -> Ast.rewrap d (Ast.CIRCLES(l))) (disjmult f l)
  42   | Ast.STARS(l) ->
  43       List.map (function l -> Ast.rewrap d (Ast.STARS(l))) (disjmult f l)
  44
  45 let rec disjty ft =
  46   match Ast.unwrap ft with
  47     Ast.Type(cv,ty) ->
  48       let ty = disjtypeC ty in
  49       List.map (function ty -> Ast.rewrap ft (Ast.Type(cv,ty))) ty
  50   | Ast.DisjType(types) -> List.concat (List.map disjty types)
  51   | Ast.OptType(ty) ->
  52       let ty = disjty ty in
  53       List.map (function ty -> Ast.rewrap ft (Ast.OptType(ty))) ty
  54   | Ast.UniqueType(ty) ->
  55       let ty = disjty ty in
  56       List.map (function ty -> Ast.rewrap ft (Ast.UniqueType(ty))) ty
  57
  58 and disjtypeC bty =
  59   match Ast.unwrap bty with
  60     Ast.BaseType(_) | Ast.SignedT(_,_) -> [bty]
  61   | Ast.Pointer(ty,star) ->
  62       let ty = disjty ty in
  63       List.map (function ty -> Ast.rewrap bty (Ast.Pointer(ty,star))) ty
  64   | Ast.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2) ->
  65       let ty = disjty ty in
  66       List.map
  67         (function ty ->
  68           Ast.rewrap bty (Ast.FunctionPointer(ty,lp1,star,rp1,lp2,params,rp2)))
  69         ty
  70   | Ast.FunctionType (s,ty,lp1,params,rp1) ->
  71       let ty = disjoption disjty ty in
  72       List.map
  73         (function ty ->
  74           Ast.rewrap bty (Ast.FunctionType (s,ty,lp1,params,rp1)))
  75         ty
  76   | Ast.Array(ty,lb,size,rb) ->
  77       disjmult2 (disjty ty) (disjoption disjexp size)
  78         (function ty -> function size ->
  79           Ast.rewrap bty (Ast.Array(ty,lb,size,rb)))
  80   | Ast.EnumName(_,_) | Ast.StructUnionName(_,_) -> [bty]
  81   | Ast.StructUnionDef(ty,lb,decls,rb) ->
  82       disjmult2 (disjty ty) (disjdots disjdecl decls)
  83         (function ty -> function decls ->
  84           Ast.rewrap bty (Ast.StructUnionDef(ty,lb,decls,rb)))
  85   | Ast.TypeName(_) | Ast.MetaType(_,_,_) -> [bty]
  86
  87 and disjexp e =
  88   match Ast.unwrap e with
  89     Ast.Ident(_) | Ast.Constant(_) -> [e]
  90   | Ast.FunCall(fn,lp,args,rp) ->
  91       disjmult2 (disjexp fn) (disjdots disjexp args)
  92         (function fn -> function args ->
  93           Ast.rewrap e (Ast.FunCall(fn,lp,args,rp)))
  94   | Ast.Assignment(left,op,right,simple) ->
  95       disjmult2 (disjexp left) (disjexp right)
  96         (function left -> function right ->
  97           Ast.rewrap e (Ast.Assignment(left,op,right,simple)))
  98   | Ast.CondExpr(exp1,why,Some exp2,colon,exp3) ->
  99       let res = disjmult disjexp [exp1;exp2;exp3] in
 100       List.map
 101         (function
 102             [exp1;exp2;exp3] ->
 103               Ast.rewrap e (Ast.CondExpr(exp1,why,Some exp2,colon,exp3))
 104           | _ -> failwith "not possible")
 105         res
 106   | Ast.CondExpr(exp1,why,None,colon,exp3) ->
 107       disjmult2 (disjexp exp1) (disjexp exp3)
 108         (function exp1 -> function exp3 ->
 109           Ast.rewrap e (Ast.CondExpr(exp1,why,None,colon,exp3)))
 110   | Ast.Postfix(exp,op) ->
 111       let exp = disjexp exp in
 112       List.map (function exp -> Ast.rewrap e (Ast.Postfix(exp,op))) exp
 113   | Ast.Infix(exp,op) ->
 114       let exp = disjexp exp in
 115       List.map (function exp -> Ast.rewrap e (Ast.Infix(exp,op))) exp
 116   | Ast.Unary(exp,op) ->
 117       let exp = disjexp exp in
 118       List.map (function exp -> Ast.rewrap e (Ast.Unary(exp,op))) exp
 119   | Ast.Binary(left,op,right) ->
 120       disjmult2 (disjexp left) (disjexp right)
 121         (function left -> function right ->
 122           Ast.rewrap e (Ast.Binary(left,op,right)))
 123   | Ast.Nested(exp,op,right) ->
 124       (* disj not possible in right *)
 125       let exp = disjexp exp in
 126       List.map (function exp -> Ast.rewrap e (Ast.Nested(exp,op,right))) exp
 127   | Ast.Paren(lp,exp,rp) ->
 128       let exp = disjexp exp in
 129       List.map (function exp -> Ast.rewrap e (Ast.Paren(lp,exp,rp))) exp
 130   | Ast.ArrayAccess(exp1,lb,exp2,rb) ->
 131       disjmult2 (disjexp exp1) (disjexp exp2)
 132         (function exp1 -> function exp2 ->
 133           Ast.rewrap e (Ast.ArrayAccess(exp1,lb,exp2,rb)))
 134   | Ast.RecordAccess(exp,pt,field) ->
 135       let exp = disjexp exp in
 136       List.map
 137         (function exp -> Ast.rewrap e (Ast.RecordAccess(exp,pt,field))) exp
 138   | Ast.RecordPtAccess(exp,ar,field) ->
 139       let exp = disjexp exp in
 140       List.map
 141         (function exp -> Ast.rewrap e (Ast.RecordPtAccess(exp,ar,field))) exp
 142   | Ast.Cast(lp,ty,rp,exp) ->
 143       disjmult2 (disjty ty) (disjexp exp)
 144         (function ty -> function exp -> Ast.rewrap e (Ast.Cast(lp,ty,rp,exp)))
 145   | Ast.SizeOfExpr(szf,exp) ->
 146       let exp = disjexp exp in
 147       List.map (function exp -> Ast.rewrap e (Ast.SizeOfExpr(szf,exp))) exp
 148   | Ast.SizeOfType(szf,lp,ty,rp) ->
 149       let ty = disjty ty in
 150       List.map
 151         (function ty -> Ast.rewrap e (Ast.SizeOfType(szf,lp,ty,rp))) ty
 152   | Ast.TypeExp(ty) ->
 153       let ty = disjty ty in
 154       List.map (function ty -> Ast.rewrap e (Ast.TypeExp(ty))) ty
 155   | Ast.MetaErr(_,_,_,_) | Ast.MetaExpr(_,_,_,_,_,_)
 156   | Ast.MetaExprList(_,_,_,_) | Ast.EComma(_) -> [e]
 157   | Ast.DisjExpr(exp_list) ->
 158       List.concat (List.map disjexp exp_list)
 159   | Ast.NestExpr(expr_dots,whencode,multi) ->
 160       (* not sure what to do here, so ambiguities still possible *)
 161       [e]
 162   | Ast.Edots(dots,_) | Ast.Ecircles(dots,_) | Ast.Estars(dots,_) -> [e]
 163   | Ast.OptExp(exp) ->
 164       let exp = disjexp exp in
 165       List.map (function exp -> Ast.rewrap e (Ast.OptExp(exp))) exp
 166   | Ast.UniqueExp(exp) ->
 167       let exp = disjexp exp in
 168       List.map (function exp -> Ast.rewrap e (Ast.UniqueExp(exp))) exp
 169
 170 and disjparam p =
 171   match Ast.unwrap p with
 172     Ast.VoidParam(ty) -> [p] (* void is the only possible value *)
 173   | Ast.Param(ty,id) ->
 174       let ty = disjty ty in
 175       List.map (function ty -> Ast.rewrap p (Ast.Param(ty,id))) ty
 176   | Ast.MetaParam(_,_,_) | Ast.MetaParamList(_,_,_,_) | Ast.PComma(_) -> [p]
 177   | Ast.Pdots(dots) | Ast.Pcircles(dots) -> [p]
 178   | Ast.OptParam(param) ->
 179       let param = disjparam param in
 180       List.map (function param -> Ast.rewrap p (Ast.OptParam(param))) param
 181   | Ast.UniqueParam(param) ->
 182       let param = disjparam param in
 183       List.map (function param -> Ast.rewrap p (Ast.UniqueParam(param))) param
 184
 185 and disjini i =
 186   match Ast.unwrap i with
 187     Ast.MetaInit(_,_,_) -> [i]
 188   | Ast.InitExpr(exp) ->
 189       let exp = disjexp exp in
 190       List.map (function exp -> Ast.rewrap i (Ast.InitExpr(exp))) exp
 191   | Ast.InitList(lb,initlist,rb,whencode) ->
 192       List.map
 193         (function initlist ->
 194           Ast.rewrap i (Ast.InitList(lb,initlist,rb,whencode)))
 195         (disjmult disjini initlist)
 196   | Ast.InitGccExt(designators,eq,ini) ->
 197       let designators = disjmult designator designators in
 198       let ini = disjini ini in
 199       disjmult2 designators ini
 200         (function designators -> function ini ->
 201           Ast.rewrap i (Ast.InitGccExt(designators,eq,ini)))
 202   | Ast.InitGccName(name,eq,ini) ->
 203       let ini = disjini ini in
 204       List.map
 205         (function ini -> Ast.rewrap i (Ast.InitGccName(name,eq,ini)))
 206         ini
 207   | Ast.IComma(comma) -> [i]
 208   | Ast.OptIni(ini) ->
 209       let ini = disjini ini in
 210       List.map (function ini -> Ast.rewrap i (Ast.OptIni(ini))) ini
 211   | Ast.UniqueIni(ini) ->
 212       let ini = disjini ini in
 213       List.map (function ini -> Ast.rewrap i (Ast.UniqueIni(ini))) ini
 214
 215 and designator = function
 216     Ast.DesignatorField(dot,id) -> [Ast.DesignatorField(dot,id)]
 217   | Ast.DesignatorIndex(lb,exp,rb) ->
 218       let exp = disjexp exp in
 219       List.map (function exp -> Ast.DesignatorIndex(lb,exp,rb)) exp
 220   | Ast.DesignatorRange(lb,min,dots,max,rb) ->
 221       disjmult2 (disjexp min) (disjexp max)
 222         (function min -> function max ->
 223           Ast.DesignatorRange(lb,min,dots,max,rb))
 224
 225 and disjdecl d =
 226   match Ast.unwrap d with
 227     Ast.Init(stg,ty,id,eq,ini,sem) ->
 228       disjmult2 (disjty ty) (disjini ini)
 229         (function ty -> function ini ->
 230           Ast.rewrap d (Ast.Init(stg,ty,id,eq,ini,sem)))
 231   | Ast.UnInit(stg,ty,id,sem) ->
 232       let ty = disjty ty in
 233       List.map (function ty -> Ast.rewrap d (Ast.UnInit(stg,ty,id,sem))) ty
 234   | Ast.MacroDecl(name,lp,args,rp,sem) ->
 235       List.map
 236         (function args -> Ast.rewrap d (Ast.MacroDecl(name,lp,args,rp,sem)))
 237         (disjdots disjexp args)
 238   | Ast.TyDecl(ty,sem) ->
 239       let ty = disjty ty in
 240       List.map (function ty -> Ast.rewrap d (Ast.TyDecl(ty,sem))) ty
 241   | Ast.Typedef(stg,ty,id,sem) ->
 242       let ty = disjty ty in (* disj not allowed in id *)
 243       List.map (function ty -> Ast.rewrap d (Ast.Typedef(stg,ty,id,sem))) ty
 244   | Ast.DisjDecl(decls) -> List.concat (List.map disjdecl decls)
 245   | Ast.Ddots(_,_) | Ast.MetaDecl(_,_,_) -> [d]
 246   | Ast.OptDecl(decl) ->
 247       let decl = disjdecl decl in
 248       List.map (function decl -> Ast.rewrap d (Ast.OptDecl(decl))) decl
 249   | Ast.UniqueDecl(decl) ->
 250       let decl = disjdecl decl in
 251       List.map (function decl -> Ast.rewrap d (Ast.UniqueDecl(decl))) decl
 252
 253 let generic_orify_rule_elem f re exp rebuild =
 254   match f exp with
 255     [exp] -> re
 256   | orexps ->
 257       Ast.rewrap re (Ast.DisjRuleElem (setify(List.map rebuild orexps)))
 258
 259 let orify_rule_elem re exp rebuild =
 260   generic_orify_rule_elem disjexp re exp rebuild
 261
 262 let orify_rule_elem_ty = generic_orify_rule_elem disjty
 263 let orify_rule_elem_param = generic_orify_rule_elem disjparam
 264 let orify_rule_elem_decl = generic_orify_rule_elem disjdecl
 265 let orify_rule_elem_ini = generic_orify_rule_elem disjini
 266
 267 let rec disj_rule_elem r k re =
 268   match Ast.unwrap re with
 269     Ast.FunHeader(bef,allminus,fninfo,name,lp,params,rp) ->
 270       generic_orify_rule_elem (disjdots disjparam) re params
 271         (function params ->
 272           Ast.rewrap re
 273             (Ast.FunHeader(bef,allminus,fninfo,name,lp,params,rp)))
 274   | Ast.Decl(bef,allminus,decl) ->
 275       orify_rule_elem_decl re decl
 276         (function decl -> Ast.rewrap re (Ast.Decl(bef,allminus,decl)))
 277   | Ast.SeqStart(brace) -> re
 278   | Ast.SeqEnd(brace) -> re
 279   | Ast.ExprStatement(exp,sem) ->
 280       orify_rule_elem re exp
 281         (function exp -> Ast.rewrap re (Ast.ExprStatement(exp,sem)))
 282   | Ast.IfHeader(iff,lp,exp,rp) ->
 283       orify_rule_elem re exp
 284         (function exp -> Ast.rewrap re (Ast.IfHeader(iff,lp,exp,rp)))
 285   | Ast.Else(els) -> re
 286   | Ast.WhileHeader(whl,lp,exp,rp) ->
 287       orify_rule_elem re exp
 288         (function exp -> Ast.rewrap re (Ast.WhileHeader(whl,lp,exp,rp)))
 289   | Ast.DoHeader(d) -> re
 290   | Ast.WhileTail(whl,lp,exp,rp,sem) ->
 291       orify_rule_elem re exp
 292         (function exp -> Ast.rewrap re (Ast.WhileTail(whl,lp,exp,rp,sem)))
 293   | Ast.ForHeader(fr,lp,e1,sem1,e2,sem2,e3,rp) ->
 294       generic_orify_rule_elem (disjmult (disjoption disjexp)) re [e1;e2;e3]
 295         (function
 296             [exp1;exp2;exp3] ->
 297               Ast.rewrap re (Ast.ForHeader(fr,lp,exp1,sem1,exp2,sem2,exp3,rp))
 298           | _ -> failwith "not possible")
 299   | Ast.IteratorHeader(whl,lp,args,rp) ->
 300       generic_orify_rule_elem (disjdots disjexp) re args
 301         (function args -> Ast.rewrap re (Ast.IteratorHeader(whl,lp,args,rp)))
 302   | Ast.SwitchHeader(switch,lp,exp,rp) ->
 303       orify_rule_elem re exp
 304         (function exp -> Ast.rewrap re (Ast.SwitchHeader(switch,lp,exp,rp)))
 305   | Ast.Break(_,_) | Ast.Continue(_,_) | Ast.Label(_,_) | Ast.Goto(_,_,_)
 306   | Ast.Return(_,_) -> re
 307   | Ast.ReturnExpr(ret,exp,sem) ->
 308       orify_rule_elem re exp
 309         (function exp -> Ast.rewrap re (Ast.ReturnExpr(ret,exp,sem)))
 310   | Ast.MetaRuleElem(_,_,_) | Ast.MetaStmt(_,_,_,_)
 311   | Ast.MetaStmtList(_,_,_) -> re
 312   | Ast.Exp(exp) ->
 313       orify_rule_elem re exp (function exp -> Ast.rewrap exp (Ast.Exp(exp)))
 314   | Ast.TopExp(exp) ->
 315       orify_rule_elem re exp (function exp -> Ast.rewrap exp (Ast.TopExp(exp)))
 316   | Ast.Ty(ty) ->
 317       orify_rule_elem_ty re ty (function ty -> Ast.rewrap ty (Ast.Ty(ty)))
 318   | Ast.TopInit(init) ->
 319       orify_rule_elem_ini re init
 320         (function init -> Ast.rewrap init (Ast.TopInit(init)))
 321   | Ast.Include(inc,s) -> re
 322   | Ast.DefineHeader(def,id,params) -> re
 323   | Ast.Default(def,colon) -> re
 324   | Ast.Case(case,exp,colon) ->
 325       orify_rule_elem re exp
 326         (function exp -> Ast.rewrap re (Ast.Case(case,exp,colon)))
 327   | Ast.DisjRuleElem(l) ->
 328       (* only case lines *)
 329       Ast.rewrap re(Ast.DisjRuleElem(setify(List.map (disj_rule_elem r k) l)))
 330
 331 let disj_all =
 332   let mcode x = x in
 333   let donothing r k e = k e in
 334   V.rebuilder
 335     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 336     donothing donothing donothing donothing
 337     donothing donothing donothing donothing donothing donothing donothing
 338     disj_rule_elem donothing donothing donothing donothing
 339
 340 (* ----------------------------------------------------------------------- *)
 341 (* collect iso information at the rule_elem level *)
 342
 343 let collect_all_isos =
 344   let bind = (@) in
 345   let option_default = [] in
 346   let mcode r x = [] in
 347   let donothing r k e = Common.union_set (Ast.get_isos e) (k e) in
 348   let doanything r k e = k e in
 349   V.combiner bind option_default
 350     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 351     donothing donothing donothing donothing donothing donothing donothing
 352     donothing donothing donothing donothing donothing donothing donothing
 353     donothing doanything
 354
 355 let collect_iso_info =
 356   let mcode x = x in
 357   let donothing r k e = k e in
 358   let rule_elem r k e =
 359     match Ast.unwrap e with
 360       Ast.DisjRuleElem(l) -> k e
 361     | _ ->
 362         let isos = collect_all_isos.V.combiner_rule_elem e in
 363         Ast.set_isos e isos in
 364   V.rebuilder
 365     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 366     donothing donothing donothing donothing donothing donothing donothing
 367     donothing donothing donothing donothing rule_elem donothing donothing
 368     donothing donothing
 369
 370 (* ----------------------------------------------------------------------- *)
 371
 372 let disj rules =
 373   List.map
 374     (function (mv,r) ->
 375       match r with
 376         Ast.ScriptRule _
 377       | Ast.InitialScriptRule _ | Ast.FinalScriptRule _ -> (mv, r)
 378       | Ast.CocciRule (nm, rule_info, r, isexp, ruletype) ->
 379           let res =
 380             List.map
 381               (function x ->
 382                 let res = disj_all.V.rebuilder_top_level x in
 383                 if !Flag.track_iso_usage
 384                 then collect_iso_info.V.rebuilder_top_level res
 385                 else res)
 386               r in
 387           (mv, Ast.CocciRule (nm,rule_info,res,isexp,ruletype)))
 388     rules