parsing_cocci/free_vars.ml

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