parsing_cocci/free_vars.ml

   1 (*
   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.
   5 *
   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.
   9 *
  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.
  14 *
  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/>.
  17 *
  18 * The authors reserve the right to distribute this or future versions of
  19 * Coccinelle under other licenses.
  20 *)
  21
  22
  23 (* For each rule return the list of variables that are used after it.
  24 Also augment various parts of each rule with unitary, inherited, and freshness
  25 informations *)
  26
  27 module Ast = Ast_cocci
  28 module V = Visitor_ast
  29 module TC = Type_cocci
  30
  31 let rec nub = function
  32     [] -> []
  33   | (x::xs) when (List.mem x xs) -> nub xs
  34   | (x::xs) -> x::(nub xs)
  35
  36 (* Collect all variable references in a minirule.  For a disj, we collect
  37 the maximum number (2 is enough) of references in any branch. *)
  38
  39 let collect_unitary_nonunitary free_usage =
  40   let free_usage = List.sort compare free_usage in
  41   let rec loop1 todrop = function (* skips multiple occurrences *)
  42       [] -> []
  43     | (x::xs) as all -> if x = todrop then loop1 todrop xs else all in
  44   let rec loop2 = function
  45       [] -> ([],[])
  46     | [x] -> ([x],[])
  47     | x::y::xs ->
  48         if x = y (* occurs more than once in free_usage *)
  49         then
  50           let (unitary,non_unitary) = loop2(loop1 x xs) in
  51           (unitary,x::non_unitary)
  52         else (* occurs only once in free_usage *)
  53           let (unitary,non_unitary) = loop2 (y::xs) in
  54           (x::unitary,non_unitary) in
  55   loop2 free_usage
  56
  57 let collect_refs include_constraints =
  58   let bind x y = x @ y in
  59   let option_default = [] in
  60
  61   let donothing recursor k e = k e in (* just combine in the normal way *)
  62
  63   let donothing_a recursor k e = (* anything is not wrapped *)
  64     k e in (* just combine in the normal way *)
  65
  66   (* the following considers that anything that occurs non-unitarily in one
  67      branch occurs nonunitarily in all branches.  This is not optimal, but
  68      doing better seems to require a breadth-first traversal, which is
  69      perhaps better to avoid.  Also, unitarily is represented as occuring once,
  70      while nonunitarily is represented as twice - more is irrelevant *)
  71   (* cases for disjs and metavars *)
  72   let bind_disj refs_branches =
  73     let (unitary,nonunitary) =
  74       List.split (List.map collect_unitary_nonunitary refs_branches) in
  75     let unitary = nub (List.concat unitary) in
  76     let nonunitary = nub (List.concat nonunitary) in
  77     let unitary =
  78       List.filter (function x -> not (List.mem x nonunitary)) unitary in
  79     unitary@nonunitary@nonunitary in
  80
  81   let metaid (x,_,_,_) = x in
  82
  83   let astfvident recursor k i =
  84     bind (k i)
  85       (match Ast.unwrap i with
  86         Ast.MetaId(name,_,_,_) | Ast.MetaFunc(name,_,_,_)
  87       | Ast.MetaLocalFunc(name,_,_,_) -> [metaid name]
  88       | _ -> option_default) in
  89
  90   let rec type_collect res = function
  91       TC.ConstVol(_,ty) | TC.Pointer(ty) | TC.FunctionPointer(ty)
  92     | TC.Array(ty) -> type_collect res ty
  93     | TC.MetaType(tyname,_,_) -> bind [tyname] res
  94     | ty -> res in
  95
  96   let astfvexpr recursor k e =
  97     bind (k e)
  98       (match Ast.unwrap e with
  99         Ast.MetaExpr(name,_,_,Some type_list,_,_) ->
 100           let types = List.fold_left type_collect option_default type_list in
 101           bind [metaid name] types
 102       | Ast.MetaErr(name,_,_,_) | Ast.MetaExpr(name,_,_,_,_,_) -> [metaid name]
 103       | Ast.MetaExprList(name,None,_,_) -> [metaid name]
 104       | Ast.MetaExprList(name,Some (lenname,_,_),_,_) ->
 105           [metaid name;metaid lenname]
 106       | Ast.DisjExpr(exps) -> bind_disj (List.map k exps)
 107       | _ -> option_default) in
 108
 109   let astfvdecls recursor k d =
 110     bind (k d)
 111       (match Ast.unwrap d with
 112         Ast.DisjDecl(decls) -> bind_disj (List.map k decls)
 113       | _ -> option_default) in
 114
 115   let astfvfullType recursor k ty =
 116     bind (k ty)
 117       (match Ast.unwrap ty with
 118         Ast.DisjType(types) -> bind_disj (List.map k types)
 119       | _ -> option_default) in
 120
 121   let astfvtypeC recursor k ty =
 122     bind (k ty)
 123       (match Ast.unwrap ty with
 124         Ast.MetaType(name,_,_) -> [metaid name]
 125       | _ -> option_default) in
 126
 127   let astfvparam recursor k p =
 128     bind (k p)
 129       (match Ast.unwrap p with
 130         Ast.MetaParam(name,_,_) -> [metaid name]
 131       | Ast.MetaParamList(name,None,_,_) -> [metaid name]
 132       | Ast.MetaParamList(name,Some(lenname,_,_),_,_) ->
 133           [metaid name;metaid lenname]
 134       | _ -> option_default) in
 135
 136   let astfvrule_elem recursor k re =
 137     (*within a rule_elem, pattern3 manages the coherence of the bindings*)
 138     bind (k re)
 139       (nub
 140          (match Ast.unwrap re with
 141            Ast.MetaRuleElem(name,_,_) | Ast.MetaStmt(name,_,_,_)
 142          | Ast.MetaStmtList(name,_,_) -> [metaid name]
 143          | _ -> option_default)) in
 144
 145   let astfvstatement recursor k s =
 146     bind (k s)
 147       (match Ast.unwrap s with
 148         Ast.Disj(stms) ->
 149           bind_disj (List.map recursor.V.combiner_statement_dots stms)
 150       | _ -> option_default) in
 151
 152   let mcode r mc =
 153     if include_constraints
 154     then
 155       match Ast.get_pos_var mc with
 156         Ast.MetaPos(name,constraints,_,_,_) -> (metaid name)::constraints
 157       | _ -> option_default
 158     else option_default in
 159
 160   V.combiner bind option_default
 161     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 162     mcode
 163     donothing donothing donothing donothing
 164     astfvident astfvexpr astfvfullType astfvtypeC donothing astfvparam
 165     astfvdecls astfvrule_elem astfvstatement donothing donothing donothing_a
 166
 167 let collect_all_refs = collect_refs true
 168 let collect_non_constraint_refs = collect_refs false
 169
 170 let collect_all_rule_refs minirules =
 171   List.fold_left (@) []
 172     (List.map collect_all_refs.V.combiner_top_level minirules)
 173
 174 let collect_all_minirule_refs = collect_all_refs.V.combiner_top_level
 175
 176 (* ---------------------------------------------------------------- *)
 177
 178 let collect_saved =
 179   let bind = Common.union_set in
 180   let option_default = [] in
 181
 182   let donothing recursor k e = k e in (* just combine in the normal way *)
 183
 184   let metaid (x,_,_,_) = x in
 185
 186   (* cases for metavariables *)
 187   let astfvident recursor k i =
 188     bind (k i)
 189       (match Ast.unwrap i with
 190         Ast.MetaId(name,_,TC.Saved,_) | Ast.MetaFunc(name,_,TC.Saved,_)
 191       | Ast.MetaLocalFunc(name,_,TC.Saved,_) -> [metaid name]
 192       | _ -> option_default) in
 193
 194   let rec type_collect res = function
 195       TC.ConstVol(_,ty) | TC.Pointer(ty) | TC.FunctionPointer(ty)
 196     | TC.Array(ty) -> type_collect res ty
 197     | TC.MetaType(tyname,TC.Saved,_) -> bind [tyname] res
 198     | ty -> res in
 199
 200   let astfvexpr recursor k e =
 201     let tymetas =
 202       match Ast.unwrap e with
 203         Ast.MetaExpr(name,_,_,Some type_list,_,_) ->
 204           List.fold_left type_collect option_default type_list
 205       | _ -> [] in
 206     let vars =
 207       bind (k e)
 208         (match Ast.unwrap e with
 209           Ast.MetaErr(name,_,TC.Saved,_) | Ast.MetaExpr(name,_,TC.Saved,_,_,_)
 210         | Ast.MetaExprList(name,None,TC.Saved,_) -> [metaid name]
 211         | Ast.MetaExprList(name,Some (lenname,ls,_),ns,_) ->
 212             let namesaved =
 213               match ns with TC.Saved -> [metaid name] | _ -> [] in
 214             let lensaved =
 215               match ls with TC.Saved -> [metaid lenname] | _ -> [] in
 216             lensaved @ namesaved
 217         | _ -> option_default) in
 218     bind tymetas vars in
 219
 220   let astfvtypeC recursor k ty =
 221     bind (k ty)
 222       (match Ast.unwrap ty with
 223         Ast.MetaType(name,TC.Saved,_) -> [metaid name]
 224       | _ -> option_default) in
 225
 226   let astfvparam recursor k p =
 227     bind (k p)
 228       (match Ast.unwrap p with
 229         Ast.MetaParam(name,TC.Saved,_)
 230       | Ast.MetaParamList(name,None,_,_) -> [metaid name]
 231       | Ast.MetaParamList(name,Some (lenname,ls,_),ns,_) ->
 232           let namesaved =
 233             match ns with TC.Saved -> [metaid name] | _ -> [] in
 234           let lensaved =
 235             match ls with TC.Saved -> [metaid lenname] | _ -> [] in
 236           lensaved @ namesaved
 237       | _ -> option_default) in
 238
 239   let astfvrule_elem recursor k re =
 240     (*within a rule_elem, pattern3 manages the coherence of the bindings*)
 241     bind (k re)
 242       (nub
 243          (match Ast.unwrap re with
 244            Ast.MetaRuleElem(name,TC.Saved,_) | Ast.MetaStmt(name,TC.Saved,_,_)
 245          | Ast.MetaStmtList(name,TC.Saved,_) -> [metaid name]
 246          | _ -> option_default)) in
 247
 248   let mcode r e =
 249     match Ast.get_pos_var e with
 250       Ast.MetaPos(name,_,_,TC.Saved,_) -> [metaid name]
 251     | _ -> option_default in
 252
 253   V.combiner bind option_default
 254     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 255     mcode
 256     donothing donothing donothing donothing
 257     astfvident astfvexpr donothing astfvtypeC donothing astfvparam
 258     donothing astfvrule_elem donothing donothing donothing donothing
 259
 260 (* ---------------------------------------------------------------- *)
 261
 262 (* For the rules under a given metavariable declaration, collect all of the
 263 variables that occur in the plus code *)
 264
 265 let cip_mcodekind r mck =
 266   let process_anything_list_list anythings =
 267     let astfvs = collect_all_refs.V.combiner_anything in
 268     List.fold_left (@) []
 269       (List.map (function l -> List.fold_left (@) [] (List.map astfvs l))
 270          anythings) in
 271   match mck with
 272     Ast.MINUS(_,anythings) -> process_anything_list_list anythings
 273   | Ast.CONTEXT(_,befaft) ->
 274       (match befaft with
 275         Ast.BEFORE(ll) -> process_anything_list_list ll
 276       | Ast.AFTER(ll) -> process_anything_list_list ll
 277       | Ast.BEFOREAFTER(llb,lla) ->
 278           (process_anything_list_list lla) @
 279           (process_anything_list_list llb)
 280       | Ast.NOTHING -> [])
 281   | Ast.PLUS -> []
 282
 283 let collect_in_plus_term =
 284   let bind x y = x @ y in
 285   let option_default = [] in
 286   let donothing r k e = k e in
 287
 288   (* no positions in the + code *)
 289   let mcode r (_,_,mck,_) = cip_mcodekind r mck in
 290
 291   (* case for things with bef/aft mcode *)
 292
 293   let astfvrule_elem recursor k re =
 294     match Ast.unwrap re with
 295       Ast.FunHeader(bef,_,fi,nm,_,params,_) ->
 296         let fi_metas =
 297           List.concat
 298             (List.map
 299                (function
 300                    Ast.FType(ty) -> collect_all_refs.V.combiner_fullType ty
 301                  | _ -> [])
 302                fi) in
 303         let nm_metas = collect_all_refs.V.combiner_ident nm in
 304         let param_metas =
 305           match Ast.unwrap params with
 306             Ast.DOTS(params) | Ast.CIRCLES(params) ->
 307               List.concat
 308                 (List.map
 309                    (function p ->
 310                      match Ast.unwrap p with
 311                        Ast.VoidParam(t) | Ast.Param(t,_) ->
 312                          collect_all_refs.V.combiner_fullType t
 313                      | _ -> [])
 314                    params)
 315           | _ -> failwith "not allowed for params" in
 316         bind fi_metas
 317           (bind nm_metas
 318              (bind param_metas
 319                 (bind (cip_mcodekind recursor bef) (k re))))
 320     | Ast.Decl(bef,_,_) ->
 321         bind (cip_mcodekind recursor bef) (k re)
 322     | _ -> k re in
 323
 324   let astfvstatement recursor k s =
 325     match Ast.unwrap s with
 326       Ast.IfThen(_,_,(_,_,_,aft)) | Ast.IfThenElse(_,_,_,_,(_,_,_,aft))
 327     | Ast.While(_,_,(_,_,_,aft)) | Ast.For(_,_,(_,_,_,aft))
 328     | Ast.Iterator(_,_,(_,_,_,aft)) ->
 329         bind (k s) (cip_mcodekind recursor aft)
 330     | _ -> k s in
 331
 332   V.combiner bind option_default
 333     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 334     mcode
 335     donothing donothing donothing donothing
 336     donothing donothing donothing donothing donothing donothing
 337     donothing astfvrule_elem astfvstatement donothing donothing donothing
 338
 339 let collect_in_plus minirules =
 340   nub
 341     (List.concat
 342        (List.map collect_in_plus_term.V.combiner_top_level minirules))
 343
 344 (* ---------------------------------------------------------------- *)
 345
 346 (* For the rules under a given metavariable declaration, collect all of the
 347 variables that occur only once and more than once in the minus code *)
 348
 349 let collect_all_multirefs minirules =
 350   let refs = List.map collect_all_refs.V.combiner_top_level minirules in
 351   collect_unitary_nonunitary (List.concat refs)
 352
 353 (* ---------------------------------------------------------------- *)
 354
 355 (* classify as unitary (no binding) or nonunitary (env binding) or saved
 356 (witness binding) *)
 357
 358 let classify_variables metavars minirules used_after =
 359   let metavars = List.map Ast.get_meta_name metavars in
 360   let (unitary,nonunitary) = collect_all_multirefs minirules in
 361   let inplus = collect_in_plus minirules in
 362
 363   let donothing r k e = k e in
 364   let check_unitary name inherited =
 365     if List.mem name inplus or List.mem name used_after
 366     then TC.Saved
 367     else if not inherited && List.mem name unitary
 368     then TC.Unitary
 369     else TC.Nonunitary in
 370
 371   let get_option f = function Some x -> Some (f x) | None -> None in
 372
 373   let classify (name,_,_,_) =
 374     let inherited = not (List.mem name metavars) in
 375     (check_unitary name inherited,inherited) in
 376
 377   let mcode mc =
 378     match Ast.get_pos_var mc with
 379       Ast.MetaPos(name,constraints,per,unitary,inherited) ->
 380         let (unitary,inherited) = classify name in
 381         Ast.set_pos_var (Ast.MetaPos(name,constraints,per,unitary,inherited))
 382           mc
 383     | _ -> mc in
 384
 385   let ident r k e =
 386     let e = k e in
 387     match Ast.unwrap e with
 388       Ast.MetaId(name,constraints,_,_) ->
 389         let (unitary,inherited) = classify name in
 390         Ast.rewrap e (Ast.MetaId(name,constraints,unitary,inherited))
 391     | Ast.MetaFunc(name,constraints,_,_) ->
 392         let (unitary,inherited) = classify name in
 393         Ast.rewrap e (Ast.MetaFunc(name,constraints,unitary,inherited))
 394     | Ast.MetaLocalFunc(name,constraints,_,_) ->
 395         let (unitary,inherited) = classify name in
 396         Ast.rewrap e (Ast.MetaLocalFunc(name,constraints,unitary,inherited))
 397     | _ -> e in
 398
 399   let rec type_infos = function
 400       TC.ConstVol(cv,ty) -> TC.ConstVol(cv,type_infos ty)
 401     | TC.Pointer(ty) -> TC.Pointer(type_infos ty)
 402     | TC.FunctionPointer(ty) -> TC.FunctionPointer(type_infos ty)
 403     | TC.Array(ty) -> TC.Array(type_infos ty)
 404     | TC.MetaType(name,_,_) ->
 405         let (unitary,inherited) = classify (name,(),(),Ast.NoMetaPos) in
 406         Type_cocci.MetaType(name,unitary,inherited)
 407     | ty -> ty in
 408
 409   let expression r k e =
 410     let e = k e in
 411     match Ast.unwrap e with
 412       Ast.MetaErr(name,constraints,_,_) ->
 413         let (unitary,inherited) = classify name in
 414         Ast.rewrap e (Ast.MetaErr(name,constraints,unitary,inherited))
 415     | Ast.MetaExpr(name,constraints,_,ty,form,_) ->
 416         let (unitary,inherited) = classify name in
 417         let ty = get_option (List.map type_infos) ty in
 418         Ast.rewrap e (Ast.MetaExpr(name,constraints,unitary,ty,form,inherited))
 419     | Ast.MetaExprList(name,None,_,_) ->
 420         (* lenname should have the same properties of being unitary or
 421            inherited as name *)
 422         let (unitary,inherited) = classify name in
 423         Ast.rewrap e (Ast.MetaExprList(name,None,unitary,inherited))
 424     | Ast.MetaExprList(name,Some(lenname,_,_),_,_) ->
 425         (* lenname should have the same properties of being unitary or
 426            inherited as name *)
 427         let (unitary,inherited) = classify name in
 428         let (lenunitary,leninherited) = classify lenname in
 429         Ast.rewrap e
 430           (Ast.MetaExprList
 431              (name,Some(lenname,lenunitary,leninherited),unitary,inherited))
 432     | _ -> e in
 433
 434   let typeC r k e =
 435     let e = k e in
 436     match Ast.unwrap e with
 437       Ast.MetaType(name,_,_) ->
 438         let (unitary,inherited) = classify name in
 439         Ast.rewrap e (Ast.MetaType(name,unitary,inherited))
 440     | _ -> e in
 441
 442   let param r k e =
 443     let e = k e in
 444     match Ast.unwrap e with
 445       Ast.MetaParam(name,_,_) ->
 446         let (unitary,inherited) = classify name in
 447         Ast.rewrap e (Ast.MetaParam(name,unitary,inherited))
 448     | Ast.MetaParamList(name,None,_,_) ->
 449         let (unitary,inherited) = classify name in
 450         Ast.rewrap e (Ast.MetaParamList(name,None,unitary,inherited))
 451     | Ast.MetaParamList(name,Some (lenname,_,_),_,_) ->
 452         let (unitary,inherited) = classify name in
 453         let (lenunitary,leninherited) = classify lenname in
 454         Ast.rewrap e
 455           (Ast.MetaParamList
 456              (name,Some (lenname,lenunitary,leninherited),unitary,inherited))
 457     | _ -> e in
 458
 459   let rule_elem r k e =
 460     let e = k e in
 461     match Ast.unwrap e with
 462       Ast.MetaStmt(name,_,msi,_) ->
 463         let (unitary,inherited) = classify name in
 464         Ast.rewrap e (Ast.MetaStmt(name,unitary,msi,inherited))
 465     | Ast.MetaStmtList(name,_,_) ->
 466         let (unitary,inherited) = classify name in
 467         Ast.rewrap e (Ast.MetaStmtList(name,unitary,inherited))
 468     | _ -> e in
 469
 470   let fn = V.rebuilder
 471       mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 472       mcode
 473       donothing donothing donothing donothing
 474       ident expression donothing typeC donothing param donothing rule_elem
 475       donothing donothing donothing donothing in
 476
 477   List.map fn.V.rebuilder_top_level minirules
 478
 479 (* ---------------------------------------------------------------- *)
 480
 481 (* For a minirule, collect the set of non-local (not in "bound") variables that
 482 are referenced.  Store them in a hash table. *)
 483
 484 (* bound means the metavariable was declared previously, not locally *)
 485
 486 (* Highly inefficient, because we call collect_all_refs on nested code
 487 multiple times.  But we get the advantage of not having too many variants
 488 of the same functions. *)
 489
 490 (* Inherited doesn't include position constraints.  If they are not bound
 491 then there is no constraint. *)
 492
 493 let astfvs metavars bound =
 494   let fresh =
 495     List.fold_left
 496       (function prev ->
 497         function
 498             Ast.MetaFreshIdDecl(_,_) as x -> (Ast.get_meta_name x)::prev
 499           | _ -> prev)
 500       [] metavars in
 501
 502   let collect_fresh = List.filter (function x -> List.mem x fresh) in
 503
 504   (* cases for the elements of anything *)
 505   let astfvrule_elem recursor k re =
 506     let minus_free = nub (collect_all_refs.V.combiner_rule_elem re) in
 507     let minus_nc_free =
 508       nub (collect_non_constraint_refs.V.combiner_rule_elem re) in
 509     let plus_free = collect_in_plus_term.V.combiner_rule_elem re in
 510     let free = Common.union_set minus_free plus_free in
 511     let nc_free = Common.union_set minus_nc_free plus_free in
 512     let unbound =
 513       List.filter (function x -> not(List.mem x bound)) free in
 514     let inherited =
 515       List.filter (function x -> List.mem x bound) nc_free in
 516     let munbound =
 517       List.filter (function x -> not(List.mem x bound)) minus_free in
 518     {(k re) with
 519       Ast.free_vars = unbound;
 520       Ast.minus_free_vars = munbound;
 521       Ast.fresh_vars = collect_fresh unbound;
 522       Ast.inherited = inherited;
 523       Ast.saved_witness = []} in
 524
 525   let astfvstatement recursor k s =
 526     let minus_free = nub (collect_all_refs.V.combiner_statement s) in
 527     let minus_nc_free =
 528       nub (collect_non_constraint_refs.V.combiner_statement s) in
 529     let plus_free = collect_in_plus_term.V.combiner_statement s in
 530     let free = Common.union_set minus_free plus_free in
 531     let nc_free = Common.union_set minus_nc_free plus_free in
 532     let classify free minus_free =
 533       let (unbound,inherited) =
 534         List.partition (function x -> not(List.mem x bound)) free in
 535       let munbound =
 536         List.filter (function x -> not(List.mem x bound)) minus_free in
 537       (unbound,munbound,collect_fresh unbound,inherited) in
 538     let res = k s in
 539     let s =
 540       match Ast.unwrap res with
 541         Ast.IfThen(header,branch,(_,_,_,aft)) ->
 542           let (unbound,_,fresh,inherited) =
 543             classify (cip_mcodekind collect_in_plus_term aft) [] in
 544           Ast.IfThen(header,branch,(unbound,fresh,inherited,aft))
 545       | Ast.IfThenElse(header,branch1,els,branch2,(_,_,_,aft)) ->
 546           let (unbound,_,fresh,inherited) =
 547             classify (cip_mcodekind collect_in_plus_term aft) [] in
 548           Ast.IfThenElse(header,branch1,els,branch2,
 549                          (unbound,fresh,inherited,aft))
 550       | Ast.While(header,body,(_,_,_,aft)) ->
 551           let (unbound,_,fresh,inherited) =
 552             classify (cip_mcodekind collect_in_plus_term aft) [] in
 553           Ast.While(header,body,(unbound,fresh,inherited,aft))
 554       | Ast.For(header,body,(_,_,_,aft)) ->
 555           let (unbound,_,fresh,inherited) =
 556             classify (cip_mcodekind collect_in_plus_term aft) [] in
 557           Ast.For(header,body,(unbound,fresh,inherited,aft))
 558       | Ast.Iterator(header,body,(_,_,_,aft)) ->
 559           let (unbound,_,fresh,inherited) =
 560             classify (cip_mcodekind collect_in_plus_term aft) [] in
 561           Ast.Iterator(header,body,(unbound,fresh,inherited,aft))
 562       | s -> s in
 563
 564     let (unbound,munbound,fresh,_) = classify free minus_free in
 565     let inherited =
 566       List.filter (function x -> List.mem x bound) nc_free in
 567     {res with
 568       Ast.node = s;
 569       Ast.free_vars = unbound;
 570       Ast.minus_free_vars = munbound;
 571       Ast.fresh_vars = collect_fresh unbound;
 572       Ast.inherited = inherited;
 573       Ast.saved_witness = []} in
 574
 575   let astfvstatement_dots recursor k sd =
 576     let minus_free = nub (collect_all_refs.V.combiner_statement_dots sd) in
 577     let minus_nc_free =
 578       nub (collect_non_constraint_refs.V.combiner_statement_dots sd) in
 579     let plus_free = collect_in_plus_term.V.combiner_statement_dots sd in
 580     let free = Common.union_set minus_free plus_free in
 581     let nc_free = Common.union_set minus_nc_free plus_free in
 582     let unbound =
 583       List.filter (function x -> not(List.mem x bound)) free in
 584     let inherited =
 585       List.filter (function x -> List.mem x bound) nc_free in
 586     let munbound =
 587       List.filter (function x -> not(List.mem x bound)) minus_free in
 588     {(k sd) with
 589       Ast.free_vars = unbound;
 590       Ast.minus_free_vars = munbound;
 591       Ast.fresh_vars = collect_fresh unbound;
 592       Ast.inherited = inherited;
 593       Ast.saved_witness = []} in
 594
 595   let astfvtoplevel recursor k tl =
 596     let saved = collect_saved.V.combiner_top_level tl in
 597     {(k tl) with Ast.saved_witness = saved} in
 598
 599   let mcode x = x in
 600   let donothing r k e = k e in
 601
 602   V.rebuilder
 603     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 604     mcode
 605     donothing donothing astfvstatement_dots donothing
 606     donothing donothing donothing donothing donothing donothing donothing
 607     astfvrule_elem astfvstatement donothing astfvtoplevel donothing
 608
 609 (*
 610 let collect_astfvs rules =
 611   let rec loop bound = function
 612       [] -> []
 613     | (metavars,(nm,rule_info,minirules))::rules ->
 614         let bound =
 615           Common.minus_set bound (List.map Ast.get_meta_name metavars) in
 616         (nm,rule_info,
 617          (List.map (astfvs metavars bound).V.rebuilder_top_level minirules))::
 618         (loop ((List.map Ast.get_meta_name metavars)@bound) rules) in
 619   loop [] rules
 620 *)
 621
 622 let collect_astfvs rules =
 623   let rec loop bound = function
 624       [] -> []
 625     | (metavars, rule)::rules ->
 626         match rule with
 627           Ast.ScriptRule (_,_,_,_) ->
 628             (* bound stays as is because script rules have no names, so no
 629                inheritance is possible *)
 630             rule::(loop bound rules)
 631         | Ast.CocciRule (nm, rule_info, minirules, isexp) ->
 632           let bound =
 633             Common.minus_set bound (List.map Ast.get_meta_name metavars) in
 634           (Ast.CocciRule
 635              (nm, rule_info,
 636               (List.map (astfvs metavars bound).V.rebuilder_top_level
 637                  minirules),
 638               isexp))::
 639             (loop ((List.map Ast.get_meta_name metavars)@bound) rules) in
 640   loop [] rules
 641
 642 (* ---------------------------------------------------------------- *)
 643 (* position variables that appear as a constraint on another position variable.
 644 a position variable also cannot appear both positively and negatively in a
 645 single rule. *)
 646
 647 let get_neg_pos_list (_,rule) used_after_list =
 648   let donothing r k e = k e in
 649   let bind (p1,np1) (p2,np2) =
 650     (Common.union_set p1 p2, Common.union_set np1 np2) in
 651   let option_default = ([],[]) in
 652   let metaid (x,_,_,_) = x in
 653   let mcode r mc =
 654     match Ast.get_pos_var mc with
 655       Ast.MetaPos(name,constraints,Ast.PER,_,_) ->
 656         ([metaid name],constraints)
 657     | Ast.MetaPos(name,constraints,Ast.ALL,_,_) ->
 658         ([],(metaid name)::constraints)
 659     | _ -> option_default in
 660   let v =
 661     V.combiner bind option_default
 662     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 663     mcode
 664     donothing donothing donothing donothing
 665     donothing donothing donothing donothing donothing donothing
 666     donothing donothing donothing donothing donothing donothing in
 667   match rule with
 668     Ast.CocciRule(_,_,minirules,_) ->
 669       List.map
 670         (function toplevel ->
 671           let (positions,neg_positions) = v.V.combiner_top_level toplevel in
 672           (if List.exists (function p -> List.mem p neg_positions) positions
 673           then
 674             failwith
 675               "a variable cannot be used both as a position and a constraint");
 676           neg_positions)
 677         minirules
 678   | Ast.ScriptRule _ -> [] (*no negated positions*)
 679
 680 (* ---------------------------------------------------------------- *)
 681
 682 (* collect used after lists, per minirule *)
 683
 684 (* defined is a list of variables that were declared in a previous metavar
 685 declaration *)
 686
 687 (* Top-level used after: For each rule collect the set of variables that
 688 are inherited, ie used but not defined.  These are accumulated back to
 689 their point of definition. *)
 690
 691
 692 let collect_top_level_used_after metavar_rule_list =
 693   let (used_after,used_after_lists) =
 694     List.fold_right
 695       (function (metavar_list,r) ->
 696         function (used_after,used_after_lists) ->
 697           let locally_defined = List.map Ast.get_meta_name metavar_list in
 698           let continue_propagation =
 699             List.filter (function x -> not(List.mem x locally_defined))
 700               used_after in
 701           let free_vars =
 702             match r with
 703               Ast.ScriptRule (_,_,mv,_) ->
 704                 List.map (function (_,(r,v)) -> (r,v)) mv
 705             | Ast.CocciRule (_,_,rule,_) ->
 706                 Common.union_set (nub (collect_all_rule_refs rule))
 707                   (collect_in_plus rule) in
 708           let inherited =
 709             List.filter (function x -> not (List.mem x locally_defined))
 710               free_vars in
 711           (Common.union_set inherited continue_propagation,
 712            used_after::used_after_lists))
 713       metavar_rule_list ([],[]) in
 714   match used_after with
 715     [] -> used_after_lists
 716   | _ ->
 717       failwith
 718         (Printf.sprintf "collect_top_level_used_after: unbound variables %s"
 719            (String.concat " " (List.map (function (_,x) -> x) used_after)))
 720
 721 let collect_local_used_after metavars minirules used_after =
 722   let locally_defined = List.map Ast.get_meta_name metavars in
 723   let rec loop defined = function
 724       [] -> (used_after,[],[])
 725     | minirule::rest ->
 726         let free_vars =
 727           Common.union_set
 728             (nub (collect_all_minirule_refs minirule))
 729             (collect_in_plus_term.V.combiner_top_level minirule) in
 730         let local_free_vars =
 731           List.filter (function x -> List.mem x locally_defined) free_vars in
 732         let new_defined = Common.union_set local_free_vars defined in
 733         let (mini_used_after,fvs_lists,mini_used_after_lists) =
 734           loop new_defined rest in
 735         let local_used = Common.union_set local_free_vars mini_used_after in
 736         let (new_used_after,new_list) =
 737           List.partition (function x -> List.mem x defined) mini_used_after in
 738         let new_used_after = Common.union_set local_used new_used_after in
 739         (new_used_after,free_vars::fvs_lists,
 740          new_list::mini_used_after_lists) in
 741   let (_,fvs_lists,used_after_lists) = loop [] minirules in
 742   (fvs_lists,used_after_lists)
 743
 744
 745 let collect_used_after metavar_rule_list =
 746   let used_after_lists = collect_top_level_used_after metavar_rule_list in
 747   List.map2
 748     (function (metavars,r) ->
 749       function used_after ->
 750         match r with
 751           Ast.ScriptRule (_,_,mv,_) -> ([], [used_after])
 752         | Ast.CocciRule (name, rule_info, minirules, _) ->
 753           collect_local_used_after metavars minirules used_after
 754     )
 755     metavar_rule_list used_after_lists
 756
 757 (* ---------------------------------------------------------------- *)
 758 (* entry point *)
 759
 760 let free_vars rules =
 761   let metavars = List.map (function (mv,rule) -> mv) rules in
 762   let (fvs_lists,used_after_lists) = List.split (collect_used_after rules) in
 763   let neg_pos_lists = List.map2 get_neg_pos_list rules used_after_lists in
 764   let positions_list = (* for all rules, assume all positions are used after *)
 765     List.map
 766       (function (mv, r) ->
 767          match r with
 768            Ast.ScriptRule _ -> []
 769          | Ast.CocciRule (_,_,rule,_) ->
 770            let positions =
 771              List.fold_left
 772                (function prev ->
 773                  function Ast.MetaPosDecl(_,nm) -> nm::prev | _ -> prev)
 774                [] mv in
 775            List.map (function _ -> positions) rule)
 776       rules in
 777   let new_rules =
 778     List.map2
 779       (function (mv,r) ->
 780         function ua ->
 781           match r with
 782             Ast.ScriptRule _ -> r
 783           | Ast.CocciRule (nm, rule_info, r, is_exp) ->
 784               Ast.CocciRule
 785                 (nm, rule_info, classify_variables mv r (List.concat ua),
 786                  is_exp))
 787       rules used_after_lists in
 788   let new_rules = collect_astfvs (List.combine metavars new_rules) in
 789   (new_rules,fvs_lists,neg_pos_lists,used_after_lists,positions_list)