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