parsing_cocci/free_vars.ml

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