parsing_cocci/free_vars.ml

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