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