parsing_cocci/free_vars.ml

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