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, 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,_,_) -> 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 simple_setup getter k re =
 573     let minus_free = nub (getter collect_all_refs re) in
 574     let minus_nc_free =
 575       nub (getter collect_non_constraint_refs re) in
 576     let plus_free =
 577       collect_fresh_seed metavars (getter collect_in_plus_term re) in
 578     let free = Common.union_set minus_free plus_free in
 579     let nc_free = Common.union_set minus_nc_free plus_free in
 580     let unbound =
 581       List.filter (function x -> not(List.mem x bound)) free in
 582     let inherited =
 583       List.filter (function x -> List.mem x bound) nc_free in
 584     let munbound =
 585       List.filter (function x -> not(List.mem x bound)) minus_free in
 586     let (matched,fresh) = collect_fresh unbound in
 587     {(k re) with
 588       Ast.free_vars = matched;
 589       Ast.minus_free_vars = munbound;
 590       Ast.fresh_vars = fresh;
 591       Ast.inherited = inherited;
 592       Ast.saved_witness = []} in
 593
 594   let astfvrule_elem recursor k re =
 595     simple_setup (function x -> x.V.combiner_rule_elem) k re in
 596
 597   let astfvstatement recursor k s =
 598     let minus_free = nub (collect_all_refs.V.combiner_statement s) in
 599     let minus_nc_free =
 600       nub (collect_non_constraint_refs.V.combiner_statement s) in
 601     let plus_free =
 602       collect_fresh_seed metavars
 603         (collect_in_plus_term.V.combiner_statement s) in
 604     let free = Common.union_set minus_free plus_free in
 605     let nc_free = Common.union_set minus_nc_free plus_free in
 606     let classify free minus_free =
 607       let (unbound,inherited) =
 608         List.partition (function x -> not(List.mem x bound)) free in
 609       let munbound =
 610         List.filter (function x -> not(List.mem x bound)) minus_free in
 611       let (matched,fresh) = collect_fresh unbound in
 612       (matched,munbound,fresh,inherited) in
 613     let res = k s in
 614     let s =
 615       let cip_plus aft =
 616         collect_fresh_seed metavars
 617           (cip_mcodekind collect_in_plus_term aft) in
 618       match Ast.unwrap res with
 619         Ast.IfThen(header,branch,(_,_,_,aft)) ->
 620           let (unbound,_,fresh,inherited) = classify (cip_plus aft) [] in
 621           Ast.IfThen(header,branch,(unbound,fresh,inherited,aft))
 622       | Ast.IfThenElse(header,branch1,els,branch2,(_,_,_,aft)) ->
 623           let (unbound,_,fresh,inherited) = classify (cip_plus aft) [] in
 624           Ast.IfThenElse(header,branch1,els,branch2,
 625                          (unbound,fresh,inherited,aft))
 626       | Ast.While(header,body,(_,_,_,aft)) ->
 627           let (unbound,_,fresh,inherited) = classify (cip_plus aft) [] in
 628           Ast.While(header,body,(unbound,fresh,inherited,aft))
 629       | Ast.For(header,body,(_,_,_,aft)) ->
 630           let (unbound,_,fresh,inherited) = classify (cip_plus aft) [] in
 631           Ast.For(header,body,(unbound,fresh,inherited,aft))
 632       | Ast.Iterator(header,body,(_,_,_,aft)) ->
 633           let (unbound,_,fresh,inherited) = classify (cip_plus aft) [] in
 634           Ast.Iterator(header,body,(unbound,fresh,inherited,aft))
 635       | s -> s in
 636
 637     let (matched,munbound,fresh,_) = classify free minus_free in
 638     let inherited =
 639       List.filter (function x -> List.mem x bound) nc_free in
 640     {res with
 641       Ast.node = s;
 642       Ast.free_vars = matched;
 643       Ast.minus_free_vars = munbound;
 644       Ast.fresh_vars = fresh;
 645       Ast.inherited = inherited;
 646       Ast.saved_witness = []} in
 647
 648   let astfvstatement_dots recursor k sd =
 649     simple_setup (function x -> x.V.combiner_statement_dots) k sd in
 650
 651   let astfvcase_line recursor k cl =
 652     simple_setup (function x -> x.V.combiner_case_line) k cl in
 653
 654   let astfvtoplevel recursor k tl =
 655     let saved = collect_saved.V.combiner_top_level tl in
 656     {(k tl) with Ast.saved_witness = saved} in
 657
 658   let mcode x = x in
 659   let donothing r k e = k e in
 660
 661   V.rebuilder
 662     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 663     donothing donothing astfvstatement_dots donothing
 664     donothing donothing donothing donothing donothing donothing donothing
 665     astfvrule_elem astfvstatement astfvcase_line astfvtoplevel donothing
 666
 667 (*
 668 let collect_astfvs rules =
 669   let rec loop bound = function
 670       [] -> []
 671     | (metavars,(nm,rule_info,minirules))::rules ->
 672         let bound =
 673           Common.minus_set bound (List.map Ast.get_meta_name metavars) in
 674         (nm,rule_info,
 675          (List.map (astfvs metavars bound).V.rebuilder_top_level minirules))::
 676         (loop ((List.map Ast.get_meta_name metavars)@bound) rules) in
 677   loop [] rules
 678 *)
 679
 680 let collect_astfvs rules =
 681   let rec loop bound = function
 682       [] -> []
 683     | (metavars, rule)::rules ->
 684         match rule with
 685           Ast.ScriptRule (_,_,_,_)
 686         | Ast.InitialScriptRule (_,_) | Ast.FinalScriptRule (_,_) ->
 687             (* bound stays as is because script rules have no names, so no
 688                inheritance is possible *)
 689             rule::(loop bound rules)
 690         | Ast.CocciRule (nm, rule_info, minirules, isexp, ruletype) ->
 691           let bound =
 692             Common.minus_set bound (List.map Ast.get_meta_name metavars) in
 693           (Ast.CocciRule
 694              (nm, rule_info,
 695               (List.map (astfvs metavars bound).V.rebuilder_top_level
 696                  minirules),
 697               isexp, ruletype))::
 698             (loop ((List.map Ast.get_meta_name metavars)@bound) rules) in
 699   loop [] rules
 700
 701 (* ---------------------------------------------------------------- *)
 702 (* position variables that appear as a constraint on another position variable.
 703 a position variable also cannot appear both positively and negatively in a
 704 single rule. *)
 705
 706 let get_neg_pos_list (_,rule) used_after_list =
 707   let donothing r k e = k e in
 708   let bind (p1,np1) (p2,np2) =
 709     (Common.union_set p1 p2, Common.union_set np1 np2) in
 710   let option_default = ([],[]) in
 711   let metaid (x,_,_,_) = x in
 712   let mcode r mc =
 713     match Ast.get_pos_var mc with
 714       Ast.MetaPos(name,constraints,Ast.PER,_,_) ->
 715         ([metaid name],constraints)
 716     | Ast.MetaPos(name,constraints,Ast.ALL,_,_) ->
 717         ([],(metaid name)::constraints)
 718     | _ -> option_default in
 719   let v =
 720     V.combiner bind option_default
 721     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 722     donothing donothing donothing donothing
 723     donothing donothing donothing donothing donothing donothing
 724     donothing donothing donothing donothing donothing donothing in
 725   match rule with
 726     Ast.CocciRule(_,_,minirules,_,_) ->
 727       List.map
 728         (function toplevel ->
 729           let (positions,neg_positions) = v.V.combiner_top_level toplevel in
 730           (if List.exists (function p -> List.mem p neg_positions) positions
 731           then
 732             failwith
 733               "a variable cannot be used both as a position and a constraint");
 734           neg_positions)
 735         minirules
 736   | Ast.ScriptRule _ | Ast.InitialScriptRule _ | Ast.FinalScriptRule _ ->
 737       (*no negated positions*) []
 738
 739 (* ---------------------------------------------------------------- *)
 740
 741 (* collect used after lists, per minirule *)
 742
 743 (* defined is a list of variables that were declared in a previous metavar
 744 declaration *)
 745
 746 (* Top-level used after: For each rule collect the set of variables that
 747 are inherited, ie used but not defined.  These are accumulated back to
 748 their point of definition. *)
 749
 750
 751 let collect_top_level_used_after metavar_rule_list =
 752   let (used_after,used_after_lists) =
 753     List.fold_right
 754       (function (metavar_list,r) ->
 755         function (used_after,used_after_lists) ->
 756           let locally_defined = List.map Ast.get_meta_name metavar_list in
 757           let continue_propagation =
 758             List.filter (function x -> not(List.mem x locally_defined))
 759               used_after in
 760           let free_vars =
 761             match r with
 762               Ast.ScriptRule (_,_,mv,_) ->
 763                 List.map (function (_,(r,v)) -> (r,v)) mv
 764             | Ast.InitialScriptRule (_,_) | Ast.FinalScriptRule (_,_) -> []
 765             | Ast.CocciRule (_,_,rule,_,_) ->
 766                 Common.union_set (nub (collect_all_rule_refs rule))
 767                   (collect_in_plus metavar_list rule) in
 768           let inherited =
 769             List.filter (function x -> not (List.mem x locally_defined))
 770               free_vars in
 771           (Common.union_set inherited continue_propagation,
 772            used_after::used_after_lists))
 773       metavar_rule_list ([],[]) in
 774   match used_after with
 775     [] -> used_after_lists
 776   | _ ->
 777       failwith
 778         (Printf.sprintf "collect_top_level_used_after: unbound variables %s"
 779            (String.concat " " (List.map (function (_,x) -> x) used_after)))
 780
 781 let collect_local_used_after metavars minirules used_after =
 782   let locally_defined = List.map Ast.get_meta_name metavars in
 783   let rec loop = function
 784       [] -> (used_after,[],[],[],[])
 785     | minirule::rest ->
 786         (* In a rule there are three kinds of local variables:
 787            1. Variables referenced in the minus or context code.
 788            These get a value by matching.  This value can be used in
 789            subsequent rules.
 790            2. Fresh variables referenced in the plus code.
 791            3. Variables referenced in the seeds of the fresh variables.
 792            There are also non-local variables. These may either be variables
 793            referenced in the minus, context, or plus code, or they may be
 794            variables referenced in the seeds of the fresh variables. *)
 795         (* Step 1: collect all references in minus/context, plus, seed
 796            code *)
 797         let variables_referenced_in_minus_context_code =
 798           nub (collect_all_minirule_refs minirule) in
 799         let variables_referenced_in_plus_code =
 800           collect_in_plus_term.V.combiner_top_level minirule in
 801         let (env_of_fresh_seeds,seeds_and_plus) =
 802           collect_fresh_seed_env
 803             metavars variables_referenced_in_plus_code in
 804         let all_free_vars =
 805           Common.union_set variables_referenced_in_minus_context_code
 806             seeds_and_plus in
 807         (* Step 2: identify locally defined ones *)
 808         let local_fresh = List.map fst env_of_fresh_seeds in
 809         let is_local =
 810           List.partition (function x -> List.mem x locally_defined) in
 811         let local_env_of_fresh_seeds =
 812           (* these have to be restricted to only one value if the associated
 813              fresh variable is used after *)
 814           List.map (function (f,ss) -> (f,is_local ss)) env_of_fresh_seeds in
 815         let (local_all_free_vars,nonlocal_all_free_vars) =
 816           is_local all_free_vars in
 817         (* Step 3, recurse on the rest of the rules, making available whatever
 818            has been defined in this one *)
 819         let (mini_used_after,fvs_lists,mini_used_after_lists,
 820              mini_fresh_used_after_lists,mini_fresh_used_after_seeds) =
 821           loop rest in
 822         (* Step 4: collect the results.  These are:
 823            1. All of the variables used non-locally in the rules starting
 824            with this one
 825            2. All of the free variables to the end of the semantic patch
 826            3. The variables that are used afterwards and defined here by
 827            matching (minus or context code)
 828            4. The variables that are used afterwards and are defined here as
 829            fresh
 830            5. The variables that are used as seeds in computing the bindings
 831            of the variables collected in part 4. *)
 832         let (local_used_after, nonlocal_used_after) =
 833           is_local mini_used_after in
 834         let (fresh_local_used_after(*4*),matched_local_used_after) =
 835           List.partition (function x -> List.mem x local_fresh)
 836             local_used_after in
 837         let matched_local_used_after(*3*) =
 838           Common.union_set matched_local_used_after nonlocal_used_after in
 839         let new_used_after = (*1*)
 840           Common.union_set nonlocal_all_free_vars nonlocal_used_after in
 841         let fresh_local_used_after_seeds =
 842           List.filter
 843             (* no point to keep variables that already are gtd to have only
 844                one value *)
 845             (function x -> not (List.mem x matched_local_used_after))
 846             (List.fold_left (function p -> function c -> Common.union_set c p)
 847                []
 848                (List.map
 849                   (function fua ->
 850                     fst (List.assoc fua local_env_of_fresh_seeds))
 851                   fresh_local_used_after)) in
 852         (new_used_after,all_free_vars::fvs_lists(*2*),
 853          matched_local_used_after::mini_used_after_lists,
 854          fresh_local_used_after::mini_fresh_used_after_lists,
 855          fresh_local_used_after_seeds::mini_fresh_used_after_seeds) in
 856   let (_,fvs_lists,used_after_lists(*ua*),
 857        fresh_used_after_lists(*fua*),fresh_used_after_lists_seeds(*fuas*)) =
 858     loop minirules in
 859   (fvs_lists,used_after_lists,
 860    fresh_used_after_lists,fresh_used_after_lists_seeds)
 861
 862
 863
 864 let collect_used_after metavar_rule_list =
 865   let used_after_lists = collect_top_level_used_after metavar_rule_list in
 866   List.map2
 867     (function (metavars,r) ->
 868       function used_after ->
 869         match r with
 870           Ast.ScriptRule (_,_,_,_)
 871         | Ast.InitialScriptRule (_,_) | Ast.FinalScriptRule (_,_) ->
 872             ([], [used_after], [], [])
 873         | Ast.CocciRule (name, rule_info, minirules, _,_) ->
 874           collect_local_used_after metavars minirules used_after
 875     )
 876     metavar_rule_list used_after_lists
 877
 878 let rec split4 = function
 879     [] -> ([],[],[],[])
 880   | (a,b,c,d)::l -> let (a1,b1,c1,d1) = split4 l in (a::a1,b::b1,c::c1,d::d1)
 881
 882 (* ---------------------------------------------------------------- *)
 883 (* entry point *)
 884
 885 let free_vars rules =
 886   let metavars = List.map (function (mv,rule) -> mv) rules in
 887   let (fvs_lists,used_after_matched_lists,
 888        fresh_used_after_lists,fresh_used_after_lists_seeds) =
 889     split4 (collect_used_after rules) in
 890   let neg_pos_lists =
 891     List.map2 get_neg_pos_list rules used_after_matched_lists in
 892   let positions_list = (* for all rules, assume all positions are used after *)
 893     List.map
 894       (function (mv, r) ->
 895          match r with
 896            Ast.ScriptRule _
 897          | Ast.InitialScriptRule _ | Ast.FinalScriptRule _ -> []
 898          | Ast.CocciRule (_,_,rule,_,_) ->
 899            let positions =
 900              List.fold_left
 901                (function prev ->
 902                  function Ast.MetaPosDecl(_,nm) -> nm::prev | _ -> prev)
 903                [] mv in
 904            List.map (function _ -> positions) rule)
 905       rules in
 906   let new_rules =
 907     List.map2
 908       (function (mv,r) ->
 909         function (ua,fua) ->
 910           match r with
 911             Ast.ScriptRule _
 912           | Ast.InitialScriptRule _ | Ast.FinalScriptRule _ -> r
 913           | Ast.CocciRule (nm, rule_info, r, is_exp,ruletype) ->
 914               Ast.CocciRule
 915                 (nm, rule_info,
 916                  classify_variables mv r
 917                    ((List.concat ua) @ (List.concat fua)),
 918                  is_exp,ruletype))
 919       rules (List.combine used_after_matched_lists fresh_used_after_lists) in
 920   let new_rules = collect_astfvs (List.combine metavars new_rules) in
 921   (metavars,new_rules,
 922    fvs_lists,neg_pos_lists,
 923    (used_after_matched_lists,
 924     fresh_used_after_lists,fresh_used_after_lists_seeds),
 925    positions_list)