parsing_cocci/free_vars.ml

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