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