parsing_cocci/free_vars.ml

   1 (*
   2  * Copyright 2010, INRIA, University of Copenhagen
   3  * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
   4  * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
   5  * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
   6  * This file is part of Coccinelle.
   7  *
   8  * Coccinelle is free software: you can redistribute it and/or modify
   9  * it under the terms of the GNU General Public License as published by
  10  * the Free Software Foundation, according to version 2 of the License.
  11  *
  12  * Coccinelle is distributed in the hope that it will be useful,
  13  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15  * GNU General Public License for more details.
  16  *
  17  * You should have received a copy of the GNU General Public License
  18  * along with Coccinelle.  If not, see <http://www.gnu.org/licenses/>.
  19  *
  20  * The authors reserve the right to distribute this or future versions of
  21  * Coccinelle under other licenses.
  22  *)
  23
  24
  25 (*
  26  * Copyright 2010, INRIA, University of Copenhagen
  27  * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
  28  * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
  29  * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
  30  * This file is part of Coccinelle.
  31  *
  32  * Coccinelle is free software: you can redistribute it and/or modify
  33  * it under the terms of the GNU General Public License as published by
  34  * the Free Software Foundation, according to version 2 of the License.
  35  *
  36  * Coccinelle is distributed in the hope that it will be useful,
  37  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  38  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  39  * GNU General Public License for more details.
  40  *
  41  * You should have received a copy of the GNU General Public License
  42  * along with Coccinelle.  If not, see <http://www.gnu.org/licenses/>.
  43  *
  44  * The authors reserve the right to distribute this or future versions of
  45  * Coccinelle under other licenses.
  46  *)
  47
  48
  49 (* For each rule return the list of variables that are used after it.
  50 Also augment various parts of each rule with unitary, inherited, and freshness
  51 informations *)
  52
  53 (* metavar decls should be better integrated into computations of free
  54 variables in plus code *)
  55
  56 module Ast = Ast_cocci
  57 module V = Visitor_ast
  58 module TC = Type_cocci
  59
  60 let rec nub = function
  61     [] -> []
  62   | (x::xs) when (List.mem x xs) -> nub xs
  63   | (x::xs) -> x::(nub xs)
  64
  65 (* Collect all variable references in a minirule.  For a disj, we collect
  66 the maximum number (2 is enough) of references in any branch. *)
  67
  68 let collect_unitary_nonunitary free_usage =
  69   let free_usage = List.sort compare free_usage in
  70   let rec loop1 todrop = function (* skips multiple occurrences *)
  71       [] -> []
  72     | (x::xs) as all -> if x = todrop then loop1 todrop xs else all in
  73   let rec loop2 = function
  74       [] -> ([],[])
  75     | [x] -> ([x],[])
  76     | x::y::xs ->
  77         if x = y (* occurs more than once in free_usage *)
  78         then
  79           let (unitary,non_unitary) = loop2(loop1 x xs) in
  80           (unitary,x::non_unitary)
  81         else (* occurs only once in free_usage *)
  82           let (unitary,non_unitary) = loop2 (y::xs) in
  83           (x::unitary,non_unitary) in
  84   loop2 free_usage
  85
  86 let collect_refs include_constraints =
  87   let bind x y = x @ y in
  88   let option_default = [] in
  89
  90   let donothing recursor k e = k e in (* just combine in the normal way *)
  91
  92   let donothing_a recursor k e = (* anything is not wrapped *)
  93     k e in (* just combine in the normal way *)
  94
  95   (* the following considers that anything that occurs non-unitarily in one
  96      branch occurs nonunitarily in all branches.  This is not optimal, but
  97      doing better seems to require a breadth-first traversal, which is
  98      perhaps better to avoid.  Also, unitarily is represented as occuring once,
  99      while nonunitarily is represented as twice - more is irrelevant *)
 100   (* cases for disjs and metavars *)
 101   let bind_disj refs_branches =
 102     let (unitary,nonunitary) =
 103       List.split (List.map collect_unitary_nonunitary refs_branches) in
 104     let unitary = nub (List.concat unitary) in
 105     let nonunitary = nub (List.concat nonunitary) in
 106     let unitary =
 107       List.filter (function x -> not (List.mem x nonunitary)) unitary in
 108     unitary@nonunitary@nonunitary in
 109
 110   let metaid (x,_,_,_) = x in
 111
 112   let astfvident recursor k i =
 113     bind (k i)
 114       (match Ast.unwrap i with
 115         Ast.MetaId(name,idconstraint,_,_) | Ast.MetaFunc(name,idconstraint,_,_)
 116       | Ast.MetaLocalFunc(name,idconstraint,_,_) ->
 117           let metas =
 118             if include_constraints
 119             then
 120               match idconstraint with
 121                 Ast.IdNegIdSet (_,metas) -> metas
 122               | _ -> []
 123             else [] in
 124           bind (List.rev metas) [metaid name]
 125       | _ -> option_default) in
 126
 127   let rec type_collect res = function
 128       TC.ConstVol(_,ty) | TC.Pointer(ty) | TC.FunctionPointer(ty)
 129     | TC.Array(ty) -> type_collect res ty
 130     | TC.EnumName(TC.MV(tyname,_,_)) ->
 131         bind [tyname] res
 132     | TC.StructUnionName(_,TC.MV(tyname,_,_)) ->
 133         bind [tyname] res
 134     | TC.MetaType(tyname,_,_) ->
 135         bind [tyname] res
 136     | TC.SignedT(_,Some ty) -> type_collect res ty
 137     | ty -> res in
 138
 139   let astfvexpr recursor k e =
 140     bind (k e)
 141       (match Ast.unwrap e with
 142         Ast.MetaExpr(name,constraints,_,Some type_list,_,_) ->
 143           let types = List.fold_left type_collect option_default type_list in
 144           let extra =
 145             if include_constraints
 146             then
 147               match constraints with
 148                 Ast.SubExpCstrt l -> l
 149               | _ -> []
 150             else [] in
 151           bind extra (bind [metaid name] types)
 152       | Ast.MetaErr(name,constraints,_,_)
 153       | Ast.MetaExpr(name,constraints,_,_,_,_) ->
 154           let extra =
 155             if include_constraints
 156             then
 157               match constraints with
 158                 Ast.SubExpCstrt l -> l
 159               | _ -> []
 160             else [] in
 161           bind extra [metaid name]
 162       | Ast.MetaExprList(name,Ast.MetaListLen (lenname,_,_),_,_) ->
 163           [metaid name;metaid lenname]
 164       | Ast.MetaExprList(name,_,_,_) -> [metaid name]
 165       | Ast.DisjExpr(exps) -> bind_disj (List.map k exps)
 166       | _ -> option_default) in
 167
 168   let astfvdecls recursor k d =
 169     bind (k d)
 170       (match Ast.unwrap d with
 171         Ast.MetaDecl(name,_,_) | Ast.MetaField(name,_,_) -> [metaid name]
 172       | Ast.DisjDecl(decls) -> bind_disj (List.map k decls)
 173       | _ -> option_default) in
 174
 175   let astfvfullType recursor k ty =
 176     bind (k ty)
 177       (match Ast.unwrap ty with
 178         Ast.DisjType(types) -> bind_disj (List.map k types)
 179       | _ -> option_default) in
 180
 181   let astfvtypeC recursor k ty =
 182     bind (k ty)
 183       (match Ast.unwrap ty with
 184         Ast.MetaType(name,_,_) -> [metaid name]
 185       | _ -> option_default) in
 186
 187   let astfvinit recursor k ty =
 188     bind (k ty)
 189       (match Ast.unwrap ty with
 190         Ast.MetaInit(name,_,_) -> [metaid name]
 191       | _ -> option_default) in
 192
 193   let astfvparam recursor k p =
 194     bind (k p)
 195       (match Ast.unwrap p with
 196         Ast.MetaParam(name,_,_) -> [metaid name]
 197       | Ast.MetaParamList(name,Ast.MetaListLen(lenname,_,_),_,_) ->
 198           [metaid name;metaid lenname]
 199       | Ast.MetaParamList(name,_,_,_) -> [metaid name]
 200       | _ -> option_default) in
 201
 202   let astfvrule_elem recursor k re =
 203     (*within a rule_elem, pattern3 manages the coherence of the bindings*)
 204     bind (k re)
 205       (nub
 206          (match Ast.unwrap re with
 207            Ast.MetaRuleElem(name,_,_) | Ast.MetaStmt(name,_,_,_)
 208          | Ast.MetaStmtList(name,_,_) -> [metaid name]
 209          | _ -> option_default)) in
 210
 211   let astfvstatement recursor k s =
 212     bind (k s)
 213       (match Ast.unwrap s with
 214         Ast.Disj(stms) ->
 215           bind_disj (List.map recursor.V.combiner_statement_dots stms)
 216       | _ -> option_default) in
 217
 218   let mcode r mc =
 219     if include_constraints
 220     then
 221       match Ast.get_pos_var mc with
 222         Ast.MetaPos(name,constraints,_,_,_) -> (metaid name)::constraints
 223       | _ -> option_default
 224     else option_default in
 225
 226   V.combiner bind option_default
 227     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 228     donothing donothing donothing donothing donothing
 229     astfvident astfvexpr astfvfullType astfvtypeC astfvinit astfvparam
 230     astfvdecls astfvrule_elem astfvstatement donothing donothing donothing_a
 231
 232 let collect_all_refs = collect_refs true
 233 let collect_non_constraint_refs = collect_refs false
 234
 235 let collect_all_rule_refs minirules =
 236   List.fold_left (@) []
 237     (List.map collect_all_refs.V.combiner_top_level minirules)
 238
 239 let collect_all_minirule_refs = collect_all_refs.V.combiner_top_level
 240
 241 (* ---------------------------------------------------------------- *)
 242
 243 let collect_saved =
 244   let bind = Common.union_set in
 245   let option_default = [] in
 246
 247   let donothing recursor k e = k e in (* just combine in the normal way *)
 248
 249   let metaid (x,_,_,_) = x in
 250
 251   (* cases for metavariables *)
 252   let astfvident recursor k i =
 253     bind (k i)
 254       (match Ast.unwrap i with
 255         Ast.MetaId(name,_,TC.Saved,_)
 256       | Ast.MetaFunc(name,_,TC.Saved,_)
 257       | Ast.MetaLocalFunc(name,_,TC.Saved,_) ->
 258           [metaid name]
 259       | _ -> option_default) in
 260
 261   let rec type_collect res = function
 262       TC.ConstVol(_,ty) | TC.Pointer(ty) | TC.FunctionPointer(ty)
 263     | TC.Array(ty) -> type_collect res ty
 264     | TC.EnumName(TC.MV(tyname,TC.Saved,_)) ->
 265         bind [tyname] res
 266     | TC.StructUnionName(_,TC.MV(tyname,TC.Saved,_)) ->
 267         bind [tyname] res
 268     | TC.MetaType(tyname,TC.Saved,_) ->
 269         bind [tyname] res
 270     | TC.SignedT(_,Some ty) -> type_collect res ty
 271     | ty -> res in
 272
 273   let astfvexpr recursor k e =
 274     let tymetas =
 275       match Ast.unwrap e with
 276         Ast.MetaExpr(name,_,_,Some type_list,_,_) ->
 277           List.fold_left type_collect option_default type_list
 278       | _ -> [] in
 279     let vars =
 280       bind (k e)
 281         (match Ast.unwrap e with
 282           Ast.MetaErr(name,_,TC.Saved,_) | Ast.MetaExpr(name,_,TC.Saved,_,_,_)
 283           -> [metaid name]
 284         | Ast.MetaExprList(name,Ast.MetaListLen (lenname,ls,_),ns,_) ->
 285             let namesaved =
 286               match ns with TC.Saved -> [metaid name] | _ -> [] in
 287             let lensaved =
 288               match ls with TC.Saved -> [metaid lenname] | _ -> [] in
 289             lensaved @ namesaved
 290         | Ast.MetaExprList(name,_,TC.Saved,_) -> [metaid name]
 291         | _ -> option_default) in
 292     bind tymetas vars in
 293
 294   let astfvtypeC recursor k ty =
 295     bind (k ty)
 296       (match Ast.unwrap ty with
 297         Ast.MetaType(name,TC.Saved,_) -> [metaid name]
 298       | _ -> option_default) in
 299
 300   let astfvinit recursor k ty =
 301     bind (k ty)
 302       (match Ast.unwrap ty with
 303         Ast.MetaInit(name,TC.Saved,_) -> [metaid name]
 304       | _ -> option_default) in
 305
 306   let astfvparam recursor k p =
 307     bind (k p)
 308       (match Ast.unwrap p with
 309         Ast.MetaParam(name,TC.Saved,_) -> [metaid name]
 310       | Ast.MetaParamList(name,Ast.MetaListLen (lenname,ls,_),ns,_) ->
 311           let namesaved =
 312             match ns with TC.Saved -> [metaid name] | _ -> [] in
 313           let lensaved =
 314             match ls with TC.Saved -> [metaid lenname] | _ -> [] in
 315           lensaved @ namesaved
 316       | Ast.MetaParamList(name,_,_,_) -> [metaid name]
 317       | _ -> option_default) in
 318
 319   let astfvdecls recursor k d =
 320     bind (k d)
 321       (match Ast.unwrap d with
 322         Ast.MetaDecl(name,TC.Saved,_) | Ast.MetaField(name,TC.Saved,_) ->
 323           [metaid name]
 324       | _ -> option_default) in
 325
 326   let astfvrule_elem recursor k re =
 327     (*within a rule_elem, pattern3 manages the coherence of the bindings*)
 328     bind (k re)
 329       (nub
 330          (match Ast.unwrap re with
 331            Ast.MetaRuleElem(name,TC.Saved,_) | Ast.MetaStmt(name,TC.Saved,_,_)
 332          | Ast.MetaStmtList(name,TC.Saved,_) -> [metaid name]
 333          | _ -> option_default)) in
 334
 335   let mcode r e =
 336     match Ast.get_pos_var e with
 337       Ast.MetaPos(name,_,_,TC.Saved,_) -> [metaid name]
 338     | _ -> option_default in
 339
 340   V.combiner bind option_default
 341     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 342     donothing donothing donothing donothing donothing
 343     astfvident astfvexpr donothing astfvtypeC astfvinit astfvparam
 344     astfvdecls astfvrule_elem donothing donothing donothing donothing
 345
 346 (* ---------------------------------------------------------------- *)
 347
 348 (* For the rules under a given metavariable declaration, collect all of the
 349 variables that occur in the plus code *)
 350
 351 let cip_mcodekind r mck =
 352   let process_anything_list_list anythings =
 353     let astfvs = collect_all_refs.V.combiner_anything in
 354     List.fold_left (@) []
 355       (List.map (function l -> List.fold_left (@) [] (List.map astfvs l))
 356          anythings) in
 357   match mck with
 358     Ast.MINUS(_,_,_,anythings) -> process_anything_list_list anythings
 359   | Ast.CONTEXT(_,befaft) ->
 360       (match befaft with
 361         Ast.BEFORE(ll,_) -> process_anything_list_list ll
 362       | Ast.AFTER(ll,_) -> process_anything_list_list ll
 363       | Ast.BEFOREAFTER(llb,lla,_) ->
 364           (process_anything_list_list lla) @
 365           (process_anything_list_list llb)
 366       | Ast.NOTHING -> [])
 367   | Ast.PLUS _ -> []
 368
 369
 370 let collect_fresh_seed_env metavars l =
 371   let fresh =
 372     List.fold_left
 373       (function prev ->
 374         function
 375             Ast.MetaFreshIdDecl(_,seed) as x ->
 376               ((Ast.get_meta_name x),seed)::prev
 377           | _ -> prev)
 378       [] metavars in
 379   let (seed_env,seeds) =
 380     List.fold_left
 381       (function (seed_env,seeds) as prev ->
 382         function x ->
 383           try
 384             (let v = List.assoc x fresh in
 385             match v with
 386               Ast.ListSeed l ->
 387                 let ids =
 388                   List.fold_left
 389                     (function prev ->
 390                       function
 391                           Ast.SeedId(id) -> id::prev
 392                         | _ -> prev)
 393                     [] l in
 394                 ((x,ids)::seed_env,Common.union_set ids seeds)
 395             | _ -> ((x,[])::seed_env,seeds))
 396           with Not_found -> prev)
 397       ([],l) l in
 398   (List.rev seed_env,List.rev seeds)
 399
 400 let collect_fresh_seed metavars l =
 401   let (_,seeds) = collect_fresh_seed_env metavars l in seeds
 402
 403 let collect_in_plus_term =
 404
 405   let bind x y = x @ y in
 406   let option_default = [] in
 407   let donothing r k e = k e in
 408
 409   (* no positions in the + code *)
 410   let mcode r (_,_,mck,_) = cip_mcodekind r mck in
 411
 412   (* case for things with bef/aft mcode *)
 413
 414   let astfvrule_elem recursor k re =
 415     match Ast.unwrap re with
 416       Ast.FunHeader(bef,_,fi,nm,_,params,_) ->
 417         let fi_metas =
 418           List.concat
 419             (List.map
 420                (function
 421                    Ast.FType(ty) -> collect_all_refs.V.combiner_fullType ty
 422                  | _ -> [])
 423                fi) in
 424         let nm_metas = collect_all_refs.V.combiner_ident nm in
 425         let param_metas =
 426           match Ast.unwrap params with
 427             Ast.DOTS(params) | Ast.CIRCLES(params) ->
 428               List.concat
 429                 (List.map
 430                    (function p ->
 431                      match Ast.unwrap p with
 432                        Ast.VoidParam(t) | Ast.Param(t,_) ->
 433                          collect_all_refs.V.combiner_fullType t
 434                      | _ -> [])
 435                    params)
 436           | _ -> failwith "not allowed for params" in
 437         bind fi_metas
 438           (bind nm_metas
 439              (bind param_metas
 440                 (bind (cip_mcodekind recursor bef) (k re))))
 441     | Ast.Decl(bef,_,_) ->
 442         bind (cip_mcodekind recursor bef) (k re)
 443     | _ -> k re in
 444
 445   let astfvstatement recursor k s =
 446     match Ast.unwrap s with
 447       Ast.IfThen(_,_,(_,_,_,aft)) | Ast.IfThenElse(_,_,_,_,(_,_,_,aft))
 448     | Ast.While(_,_,(_,_,_,aft)) | Ast.For(_,_,(_,_,_,aft))
 449     | Ast.Iterator(_,_,(_,_,_,aft)) ->
 450         bind (k s) (cip_mcodekind recursor aft)
 451     | _ -> k s in
 452
 453   V.combiner bind option_default
 454     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 455     donothing donothing donothing donothing donothing
 456     donothing donothing donothing donothing donothing donothing
 457     donothing astfvrule_elem astfvstatement donothing donothing donothing
 458
 459 let collect_in_plus metavars minirules =
 460   nub
 461     (collect_fresh_seed metavars
 462        (List.concat
 463           (List.map collect_in_plus_term.V.combiner_top_level minirules)))
 464
 465 (* ---------------------------------------------------------------- *)
 466
 467 (* For the rules under a given metavariable declaration, collect all of the
 468 variables that occur only once and more than once in the minus code *)
 469
 470 let collect_all_multirefs minirules =
 471   let refs = List.map collect_all_refs.V.combiner_top_level minirules in
 472   collect_unitary_nonunitary (List.concat refs)
 473
 474 (* ---------------------------------------------------------------- *)
 475
 476 (* classify as unitary (no binding) or nonunitary (env binding) or saved
 477 (witness binding) *)
 478
 479 let classify_variables metavar_decls minirules used_after =
 480   let metavars = List.map Ast.get_meta_name metavar_decls in
 481   let (unitary,nonunitary) = collect_all_multirefs minirules in
 482   let inplus = collect_in_plus metavar_decls minirules in
 483
 484   let donothing r k e = k e in
 485   let check_unitary name inherited =
 486     if List.mem name inplus or List.mem name used_after
 487     then TC.Saved
 488     else if not inherited && List.mem name unitary
 489     then TC.Unitary
 490     else TC.Nonunitary in
 491
 492   let get_option f = function Some x -> Some (f x) | None -> None in
 493
 494   let classify (name,_,_,_) =
 495     let inherited = not (List.mem name metavars) in
 496     (check_unitary name inherited,inherited) in
 497
 498   let mcode mc =
 499     match Ast.get_pos_var mc with
 500       Ast.MetaPos(name,constraints,per,unitary,inherited) ->
 501         let (unitary,inherited) = classify name in
 502         Ast.set_pos_var (Ast.MetaPos(name,constraints,per,unitary,inherited))
 503           mc
 504     | _ -> mc in
 505
 506   let ident r k e =
 507     let e = k e in
 508     match Ast.unwrap e with
 509       Ast.MetaId(name,constraints,_,_) ->
 510         let (unitary,inherited) = classify name in
 511         Ast.rewrap e
 512           (Ast.MetaId(name,constraints,unitary,inherited))
 513     | Ast.MetaFunc(name,constraints,_,_) ->
 514         let (unitary,inherited) = classify name in
 515         Ast.rewrap e (Ast.MetaFunc(name,constraints,unitary,inherited))
 516     | Ast.MetaLocalFunc(name,constraints,_,_) ->
 517         let (unitary,inherited) = classify name in
 518         Ast.rewrap e (Ast.MetaLocalFunc(name,constraints,unitary,inherited))
 519     | _ -> e in
 520
 521   let rec type_infos = function
 522       TC.ConstVol(cv,ty) -> TC.ConstVol(cv,type_infos ty)
 523     | TC.Pointer(ty) -> TC.Pointer(type_infos ty)
 524     | TC.FunctionPointer(ty) -> TC.FunctionPointer(type_infos ty)
 525     | TC.Array(ty) -> TC.Array(type_infos ty)
 526     | TC.EnumName(TC.MV(name,_,_)) ->
 527         let (unitary,inherited) = classify (name,(),(),Ast.NoMetaPos) in
 528         TC.EnumName(TC.MV(name,unitary,inherited))
 529     | TC.StructUnionName(su,TC.MV(name,_,_)) ->
 530         let (unitary,inherited) = classify (name,(),(),Ast.NoMetaPos) in
 531         TC.StructUnionName(su,TC.MV(name,unitary,inherited))
 532     | TC.MetaType(name,_,_) ->
 533         let (unitary,inherited) = classify (name,(),(),Ast.NoMetaPos) in
 534         Type_cocci.MetaType(name,unitary,inherited)
 535     | TC.SignedT(sgn,Some ty) -> TC.SignedT(sgn,Some (type_infos ty))
 536     | ty -> ty in
 537
 538   let expression r k e =
 539     let e = k e in
 540     match Ast.unwrap e with
 541       Ast.MetaErr(name,constraints,_,_) ->
 542         let (unitary,inherited) = classify name in
 543         Ast.rewrap e (Ast.MetaErr(name,constraints,unitary,inherited))
 544     | Ast.MetaExpr(name,constraints,_,ty,form,_) ->
 545         let (unitary,inherited) = classify name in
 546         let ty = get_option (List.map type_infos) ty in
 547         Ast.rewrap e (Ast.MetaExpr(name,constraints,unitary,ty,form,inherited))
 548     | Ast.MetaExprList(name,Ast.MetaListLen(lenname,_,_),_,_) ->
 549         (* lenname should have the same properties of being unitary or
 550            inherited as name *)
 551         let (unitary,inherited) = classify name in
 552         let (lenunitary,leninherited) = classify lenname in
 553         Ast.rewrap e
 554           (Ast.MetaExprList
 555              (name,
 556               Ast.MetaListLen(lenname,lenunitary,leninherited),
 557               unitary,inherited))
 558     | Ast.MetaExprList(name,lenname,_,_) ->
 559         (* lenname should have the same properties of being unitary or
 560            inherited as name *)
 561         let (unitary,inherited) = classify name in
 562         Ast.rewrap e (Ast.MetaExprList(name,lenname,unitary,inherited))
 563     | _ -> e in
 564
 565   let typeC r k e =
 566     let e = k e in
 567     match Ast.unwrap e with
 568       Ast.MetaType(name,_,_) ->
 569         let (unitary,inherited) = classify name in
 570         Ast.rewrap e (Ast.MetaType(name,unitary,inherited))
 571     | _ -> e in
 572
 573   let init r k e =
 574     let e = k e in
 575     match Ast.unwrap e with
 576       Ast.MetaInit(name,_,_) ->
 577         let (unitary,inherited) = classify name in
 578         Ast.rewrap e (Ast.MetaInit(name,unitary,inherited))
 579     | _ -> e in
 580
 581   let param r k e =
 582     let e = k e in
 583     match Ast.unwrap e with
 584       Ast.MetaParam(name,_,_) ->
 585         let (unitary,inherited) = classify name in
 586         Ast.rewrap e (Ast.MetaParam(name,unitary,inherited))
 587     | Ast.MetaParamList(name,Ast.MetaListLen (lenname,_,_),_,_) ->
 588         let (unitary,inherited) = classify name in
 589         let (lenunitary,leninherited) = classify lenname in
 590         Ast.rewrap e
 591           (Ast.MetaParamList
 592              (name,Ast.MetaListLen(lenname,lenunitary,leninherited),
 593               unitary,inherited))
 594     | Ast.MetaParamList(name,lenname,_,_) ->
 595         let (unitary,inherited) = classify name in
 596         Ast.rewrap e (Ast.MetaParamList(name,lenname,unitary,inherited))
 597     | _ -> e in
 598
 599   let decl r k e =
 600     let e = k e in
 601     match Ast.unwrap e with
 602       Ast.MetaDecl(name,_,_) ->
 603         let (unitary,inherited) = classify name in
 604         Ast.rewrap e (Ast.MetaDecl(name,unitary,inherited))
 605     | Ast.MetaField(name,_,_) ->
 606         let (unitary,inherited) = classify name in
 607         Ast.rewrap e (Ast.MetaField(name,unitary,inherited))
 608     | _ -> e in
 609
 610   let rule_elem r k e =
 611     let e = k e in
 612     match Ast.unwrap e with
 613       Ast.MetaStmt(name,_,msi,_) ->
 614         let (unitary,inherited) = classify name in
 615         Ast.rewrap e (Ast.MetaStmt(name,unitary,msi,inherited))
 616     | Ast.MetaStmtList(name,_,_) ->
 617         let (unitary,inherited) = classify name in
 618         Ast.rewrap e (Ast.MetaStmtList(name,unitary,inherited))
 619     | _ -> e in
 620
 621   let fn = V.rebuilder
 622       mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 623       donothing donothing donothing donothing donothing
 624       ident expression donothing typeC init param decl rule_elem
 625       donothing donothing donothing donothing in
 626
 627   List.map fn.V.rebuilder_top_level minirules
 628
 629 (* ---------------------------------------------------------------- *)
 630
 631 (* For a minirule, collect the set of non-local (not in "bound") variables that
 632 are referenced.  Store them in a hash table. *)
 633
 634 (* bound means the metavariable was declared previously, not locally *)
 635
 636 (* Highly inefficient, because we call collect_all_refs on nested code
 637 multiple times.  But we get the advantage of not having too many variants
 638 of the same functions. *)
 639
 640 (* Inherited doesn't include position constraints.  If they are not bound
 641 then there is no constraint. *)
 642
 643 let astfvs metavars bound =
 644   let fresh =
 645     List.fold_left
 646       (function prev ->
 647         function
 648             Ast.MetaFreshIdDecl(_,seed) as x ->
 649               ((Ast.get_meta_name x),seed)::prev
 650           | _ -> prev)
 651       [] metavars in
 652
 653   let collect_fresh l =
 654     let (matched,freshvars) =
 655       List.fold_left
 656         (function (matched,freshvars) ->
 657           function x ->
 658             try let v = List.assoc x fresh in (matched,(x,v)::freshvars)
 659             with Not_found -> (x::matched,freshvars))
 660         ([],[]) l in
 661     (List.rev matched, List.rev freshvars) in
 662
 663   (* cases for the elements of anything *)
 664   let simple_setup getter k re =
 665     let minus_free = nub (getter collect_all_refs re) in
 666     let minus_nc_free =
 667       nub (getter collect_non_constraint_refs re) in
 668     let plus_free =
 669       collect_fresh_seed metavars (getter collect_in_plus_term re) in
 670     let free = Common.union_set minus_free plus_free in
 671     let nc_free = Common.union_set minus_nc_free plus_free in
 672     let unbound =
 673       List.filter (function x -> not(List.mem x bound)) free in
 674     let inherited =
 675       List.filter (function x -> List.mem x bound) nc_free in
 676     let munbound =
 677       List.filter (function x -> not(List.mem x bound)) minus_free in
 678     let (matched,fresh) = collect_fresh unbound in
 679     {(k re) with
 680       Ast.free_vars = matched;
 681       Ast.minus_free_vars = munbound;
 682       Ast.fresh_vars = fresh;
 683       Ast.inherited = inherited;
 684       Ast.saved_witness = []} in
 685
 686   let astfvrule_elem recursor k re =
 687     simple_setup (function x -> x.V.combiner_rule_elem) k re in
 688
 689   let astfvstatement recursor k s =
 690     let minus_free = nub (collect_all_refs.V.combiner_statement s) in
 691     let minus_nc_free =
 692       nub (collect_non_constraint_refs.V.combiner_statement s) in
 693     let plus_free =
 694       collect_fresh_seed metavars
 695         (collect_in_plus_term.V.combiner_statement s) in
 696     let free = Common.union_set minus_free plus_free in
 697     let nc_free = Common.union_set minus_nc_free plus_free in
 698     let classify free minus_free =
 699       let (unbound,inherited) =
 700         List.partition (function x -> not(List.mem x bound)) free in
 701       let munbound =
 702         List.filter (function x -> not(List.mem x bound)) minus_free in
 703       let (matched,fresh) = collect_fresh unbound in
 704       (matched,munbound,fresh,inherited) in
 705     let res = k s in
 706     let s =
 707       let cip_plus aft =
 708         collect_fresh_seed metavars
 709           (cip_mcodekind collect_in_plus_term aft) in
 710       match Ast.unwrap res with
 711         Ast.IfThen(header,branch,(_,_,_,aft)) ->
 712           let (unbound,_,fresh,inherited) = classify (cip_plus aft) [] in
 713           Ast.IfThen(header,branch,(unbound,fresh,inherited,aft))
 714       | Ast.IfThenElse(header,branch1,els,branch2,(_,_,_,aft)) ->
 715           let (unbound,_,fresh,inherited) = classify (cip_plus aft) [] in
 716           Ast.IfThenElse(header,branch1,els,branch2,
 717                          (unbound,fresh,inherited,aft))
 718       | Ast.While(header,body,(_,_,_,aft)) ->
 719           let (unbound,_,fresh,inherited) = classify (cip_plus aft) [] in
 720           Ast.While(header,body,(unbound,fresh,inherited,aft))
 721       | Ast.For(header,body,(_,_,_,aft)) ->
 722           let (unbound,_,fresh,inherited) = classify (cip_plus aft) [] in
 723           Ast.For(header,body,(unbound,fresh,inherited,aft))
 724       | Ast.Iterator(header,body,(_,_,_,aft)) ->
 725           let (unbound,_,fresh,inherited) = classify (cip_plus aft) [] in
 726           Ast.Iterator(header,body,(unbound,fresh,inherited,aft))
 727       | s -> s in
 728
 729     let (matched,munbound,fresh,_) = classify free minus_free in
 730     let inherited =
 731       List.filter (function x -> List.mem x bound) nc_free in
 732     {res with
 733       Ast.node = s;
 734       Ast.free_vars = matched;
 735       Ast.minus_free_vars = munbound;
 736       Ast.fresh_vars = fresh;
 737       Ast.inherited = inherited;
 738       Ast.saved_witness = []} in
 739
 740   let astfvstatement_dots recursor k sd =
 741     simple_setup (function x -> x.V.combiner_statement_dots) k sd in
 742
 743   let astfvcase_line recursor k cl =
 744     simple_setup (function x -> x.V.combiner_case_line) k cl in
 745
 746   let astfvtoplevel recursor k tl =
 747     let saved = collect_saved.V.combiner_top_level tl in
 748     {(k tl) with Ast.saved_witness = saved} in
 749
 750   let mcode x = x in
 751   let donothing r k e = k e in
 752
 753   V.rebuilder
 754     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 755     donothing donothing astfvstatement_dots donothing donothing
 756     donothing donothing donothing donothing donothing donothing donothing
 757     astfvrule_elem astfvstatement astfvcase_line astfvtoplevel donothing
 758
 759 (*
 760 let collect_astfvs rules =
 761   let rec loop bound = function
 762       [] -> []
 763     | (metavars,(nm,rule_info,minirules))::rules ->
 764         let bound =
 765           Common.minus_set bound (List.map Ast.get_meta_name metavars) in
 766         (nm,rule_info,
 767          (List.map (astfvs metavars bound).V.rebuilder_top_level minirules))::
 768         (loop ((List.map Ast.get_meta_name metavars)@bound) rules) in
 769   loop [] rules
 770 *)
 771
 772 let collect_astfvs rules =
 773   let rec loop bound = function
 774       [] -> []
 775     | (metavars, rule)::rules ->
 776         match rule with
 777           Ast.ScriptRule (_,_,_,_,script_vars,_) ->
 778             (* why are metavars in rule, but outside for cocci rule??? *)
 779             let bound = script_vars @ bound in
 780             rule::(loop bound rules)
 781         | Ast.InitialScriptRule (_,_,_,_) | Ast.FinalScriptRule (_,_,_,_) ->
 782             (* bound stays as is because script rules have no names, so no
 783                inheritance is possible *)
 784             rule::(loop bound rules)
 785         | Ast.CocciRule (nm, rule_info, minirules, isexp, ruletype) ->
 786           let bound =
 787             Common.minus_set bound (List.map Ast.get_meta_name metavars) in
 788           (Ast.CocciRule
 789              (nm, rule_info,
 790               (List.map (astfvs metavars bound).V.rebuilder_top_level
 791                  minirules),
 792               isexp, ruletype))::
 793             (loop ((List.map Ast.get_meta_name metavars)@bound) rules) in
 794   loop [] rules
 795
 796 (* ---------------------------------------------------------------- *)
 797 (* position variables that appear as a constraint on another position variable.
 798 a position variable also cannot appear both positively and negatively in a
 799 single rule. *)
 800
 801 let get_neg_pos_list (_,rule) used_after_list =
 802   let donothing r k e = k e in
 803   let bind (p1,np1) (p2,np2) =
 804     (Common.union_set p1 p2, Common.union_set np1 np2) in
 805   let option_default = ([],[]) in
 806   let metaid (x,_,_,_) = x in
 807   let mcode r mc =
 808     match Ast.get_pos_var mc with
 809       Ast.MetaPos(name,constraints,Ast.PER,_,_) ->
 810         ([metaid name],constraints)
 811     | Ast.MetaPos(name,constraints,Ast.ALL,_,_) ->
 812         ([],(metaid name)::constraints)
 813     | _ -> option_default in
 814   let v =
 815     V.combiner bind option_default
 816     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 817     donothing donothing donothing donothing donothing
 818     donothing donothing donothing donothing donothing donothing
 819     donothing donothing donothing donothing donothing donothing in
 820   match rule with
 821     Ast.CocciRule(_,_,minirules,_,_) ->
 822       List.map
 823         (function toplevel ->
 824           let (positions,neg_positions) = v.V.combiner_top_level toplevel in
 825           (if List.exists (function p -> List.mem p neg_positions) positions
 826           then
 827             failwith
 828               "a variable cannot be used both as a position and a constraint");
 829           neg_positions)
 830         minirules
 831   | Ast.ScriptRule _ | Ast.InitialScriptRule _ | Ast.FinalScriptRule _ ->
 832       (*no negated positions*) []
 833
 834 (* ---------------------------------------------------------------- *)
 835
 836 (* collect used after lists, per minirule *)
 837
 838 (* defined is a list of variables that were declared in a previous metavar
 839 declaration *)
 840
 841 (* Top-level used after: For each rule collect the set of variables that
 842 are inherited, ie used but not defined.  These are accumulated back to
 843 their point of definition. *)
 844
 845
 846 let collect_top_level_used_after metavar_rule_list =
 847   let drop_virt = List.filter (function ("virtual",_) -> false | _ -> true) in
 848   let (used_after,used_after_lists) =
 849     List.fold_right
 850       (function (metavar_list,r) ->
 851         function (used_after,used_after_lists) ->
 852           let locally_defined =
 853             match r with
 854               Ast.ScriptRule (_,_,_,_,free_vars,_) -> free_vars
 855             | _ -> List.map Ast.get_meta_name metavar_list in
 856           let continue_propagation =
 857             List.filter (function x -> not(List.mem x locally_defined))
 858               used_after in
 859           let free_vars =
 860             match r with
 861               Ast.ScriptRule (_,_,_,mv,_,_) ->
 862                 drop_virt(List.map (function (_,(r,v),_) -> (r,v)) mv)
 863             | Ast.InitialScriptRule (_,_,_,_)
 864             | Ast.FinalScriptRule (_,_,_,_) -> []
 865             | Ast.CocciRule (_,_,rule,_,_) ->
 866                 drop_virt
 867                   (Common.union_set (nub (collect_all_rule_refs rule))
 868                      (collect_in_plus metavar_list rule)) in
 869           let inherited =
 870             List.filter (function x -> not (List.mem x locally_defined))
 871               free_vars in
 872           (Common.union_set inherited continue_propagation,
 873            used_after::used_after_lists))
 874       metavar_rule_list ([],[]) in
 875   match used_after with
 876     [] -> used_after_lists
 877   | _ ->
 878       failwith
 879         (Printf.sprintf "collect_top_level_used_after: unbound variables %s"
 880            (String.concat " " (List.map (function (_,x) -> x) used_after)))
 881
 882 let collect_local_used_after metavars minirules used_after =
 883   let locally_defined = List.map Ast.get_meta_name metavars in
 884   let rec loop = function
 885       [] -> (used_after,[],[],[],[])
 886     | minirule::rest ->
 887         (* In a rule there are three kinds of local variables:
 888            1. Variables referenced in the minus or context code.
 889            These get a value by matching.  This value can be used in
 890            subsequent rules.
 891            2. Fresh variables referenced in the plus code.
 892            3. Variables referenced in the seeds of the fresh variables.
 893            There are also non-local variables. These may either be variables
 894            referenced in the minus, context, or plus code, or they may be
 895            variables referenced in the seeds of the fresh variables. *)
 896         (* Step 1: collect all references in minus/context, plus, seed
 897            code *)
 898         let variables_referenced_in_minus_context_code =
 899           nub (collect_all_minirule_refs minirule) in
 900         let variables_referenced_in_plus_code =
 901           collect_in_plus_term.V.combiner_top_level minirule in
 902         let (env_of_fresh_seeds,seeds_and_plus) =
 903           collect_fresh_seed_env
 904             metavars variables_referenced_in_plus_code in
 905         let all_free_vars =
 906           Common.union_set variables_referenced_in_minus_context_code
 907             seeds_and_plus in
 908         (* Step 2: identify locally defined ones *)
 909         let local_fresh = List.map fst env_of_fresh_seeds in
 910         let is_local =
 911           List.partition (function x -> List.mem x locally_defined) in
 912         let local_env_of_fresh_seeds =
 913           (* these have to be restricted to only one value if the associated
 914              fresh variable is used after *)
 915           List.map (function (f,ss) -> (f,is_local ss)) env_of_fresh_seeds in
 916         let (local_all_free_vars,nonlocal_all_free_vars) =
 917           is_local all_free_vars in
 918         (* Step 3, recurse on the rest of the rules, making available whatever
 919            has been defined in this one *)
 920         let (mini_used_after,fvs_lists,mini_used_after_lists,
 921              mini_fresh_used_after_lists,mini_fresh_used_after_seeds) =
 922           loop rest in
 923         (* Step 4: collect the results.  These are:
 924            1. All of the variables used non-locally in the rules starting
 925            with this one
 926            2. All of the free variables to the end of the semantic patch
 927            3. The variables that are used afterwards and defined here by
 928            matching (minus or context code)
 929            4. The variables that are used afterwards and are defined here as
 930            fresh
 931            5. The variables that are used as seeds in computing the bindings
 932            of the variables collected in part 4. *)
 933         let (local_used_after, nonlocal_used_after) =
 934           is_local mini_used_after in
 935         let (fresh_local_used_after(*4*),matched_local_used_after) =
 936           List.partition (function x -> List.mem x local_fresh)
 937             local_used_after in
 938         let matched_local_used_after(*3*) =
 939           Common.union_set matched_local_used_after nonlocal_used_after in
 940         let new_used_after = (*1*)
 941           Common.union_set nonlocal_all_free_vars nonlocal_used_after in
 942         let fresh_local_used_after_seeds =
 943           List.filter
 944             (* no point to keep variables that already are gtd to have only
 945                one value *)
 946             (function x -> not (List.mem x matched_local_used_after))
 947             (List.fold_left (function p -> function c -> Common.union_set c p)
 948                []
 949                (List.map
 950                   (function fua ->
 951                     fst (List.assoc fua local_env_of_fresh_seeds))
 952                   fresh_local_used_after)) in
 953         (new_used_after,all_free_vars::fvs_lists(*2*),
 954          matched_local_used_after::mini_used_after_lists,
 955          fresh_local_used_after::mini_fresh_used_after_lists,
 956          fresh_local_used_after_seeds::mini_fresh_used_after_seeds) in
 957   let (_,fvs_lists,used_after_lists(*ua*),
 958        fresh_used_after_lists(*fua*),fresh_used_after_lists_seeds(*fuas*)) =
 959     loop minirules in
 960   (fvs_lists,used_after_lists,
 961    fresh_used_after_lists,fresh_used_after_lists_seeds)
 962
 963
 964
 965 let collect_used_after metavar_rule_list =
 966   let used_after_lists = collect_top_level_used_after metavar_rule_list in
 967   List.map2
 968     (function (metavars,r) ->
 969       function used_after ->
 970         match r with
 971           Ast.ScriptRule (_,_,_,_,_,_) (* no minirules, so nothing to do? *)
 972         | Ast.InitialScriptRule (_,_,_,_) | Ast.FinalScriptRule (_,_,_,_) ->
 973             ([], [used_after], [[]], [])
 974         | Ast.CocciRule (name, rule_info, minirules, _,_) ->
 975           collect_local_used_after metavars minirules used_after
 976     )
 977     metavar_rule_list used_after_lists
 978
 979 let rec split4 = function
 980     [] -> ([],[],[],[])
 981   | (a,b,c,d)::l -> let (a1,b1,c1,d1) = split4 l in (a::a1,b::b1,c::c1,d::d1)
 982
 983 (* ---------------------------------------------------------------- *)
 984 (* entry point *)
 985
 986 let free_vars rules =
 987   let metavars = List.map (function (mv,rule) -> mv) rules in
 988   let (fvs_lists,used_after_matched_lists,
 989        fresh_used_after_lists,fresh_used_after_lists_seeds) =
 990     split4 (collect_used_after rules) in
 991   let neg_pos_lists =
 992     List.map2 get_neg_pos_list rules used_after_matched_lists in
 993   let positions_list = (* for all rules, assume all positions are used after *)
 994     List.map
 995       (function (mv, r) ->
 996          match r with
 997            Ast.ScriptRule _ (* doesn't declare position variables *)
 998          | Ast.InitialScriptRule _ | Ast.FinalScriptRule _ -> []
 999          | Ast.CocciRule (_,_,rule,_,_) ->
1000            let positions =
1001              List.fold_left
1002                (function prev ->
1003                  function Ast.MetaPosDecl(_,nm) -> nm::prev | _ -> prev)
1004                [] mv in
1005            List.map (function _ -> positions) rule)
1006       rules in
1007   let new_rules =
1008     List.map2
1009       (function (mv,r) ->
1010         function (ua,fua) ->
1011           match r with
1012             Ast.ScriptRule _
1013           | Ast.InitialScriptRule _ | Ast.FinalScriptRule _ -> r
1014           | Ast.CocciRule (nm, rule_info, r, is_exp,ruletype) ->
1015               Ast.CocciRule
1016                 (nm, rule_info,
1017                  classify_variables mv r
1018                    ((List.concat ua) @ (List.concat fua)),
1019                  is_exp,ruletype))
1020       rules (List.combine used_after_matched_lists fresh_used_after_lists) in
1021   let new_rules = collect_astfvs (List.combine metavars new_rules) in
1022   (metavars,new_rules,
1023    fvs_lists,neg_pos_lists,
1024    (used_after_matched_lists,
1025     fresh_used_after_lists,fresh_used_after_lists_seeds),
1026    positions_list)