parsing_cocci/free_vars.ml

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