parsing_cocci/unitary_ast0.ml

   1 (*
   2 * Copyright 2005-2008, Ecole des Mines de Nantes, University of Copenhagen
   3 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
   4 * This file is part of Coccinelle.
   5 *
   6 * Coccinelle is free software: you can redistribute it and/or modify
   7 * it under the terms of the GNU General Public License as published by
   8 * the Free Software Foundation, according to version 2 of the License.
   9 *
  10 * Coccinelle is distributed in the hope that it will be useful,
  11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 * GNU General Public License for more details.
  14 *
  15 * You should have received a copy of the GNU General Public License
  16 * along with Coccinelle.  If not, see <http://www.gnu.org/licenses/>.
  17 *
  18 * The authors reserve the right to distribute this or future versions of
  19 * Coccinelle under other licenses.
  20 *)
  21
  22
  23 (* find unitary metavariables *)
  24 module Ast0 = Ast0_cocci
  25 module Ast = Ast_cocci
  26 module V0 = Visitor_ast0
  27
  28 let set_minus s minus = List.filter (function n -> not (List.mem n minus)) s
  29
  30 let rec nub = function
  31     [] -> []
  32   | (x::xs) when (List.mem x xs) -> nub xs
  33   | (x::xs) -> x::(nub xs)
  34
  35 (* ----------------------------------------------------------------------- *)
  36 (* Find the variables that occur free and occur free in a unitary way *)
  37
  38 (* take everything *)
  39 let minus_checker name = let id = Ast0.unwrap_mcode name in [id]
  40
  41 (* take only what is in the plus code *)
  42 let plus_checker (nm,_,_,mc,_) =
  43   match mc with Ast0.PLUS -> [nm] | _ -> []
  44
  45 let get_free checker t =
  46   let bind x y = x @ y in
  47   let option_default = [] in
  48   let donothing r k e = k e in
  49   let mcode _ = option_default in
  50
  51   (* considers a single list *)
  52   let collect_unitary_nonunitary free_usage =
  53     let free_usage = List.sort compare free_usage in
  54     let rec loop1 todrop = function
  55         [] -> []
  56       | (x::xs) as all -> if x = todrop then loop1 todrop xs else all in
  57     let rec loop2 = function
  58         [] -> ([],[])
  59       | [x] -> ([x],[])
  60       | x::y::xs ->
  61           if x = y
  62           then
  63             let (unitary,non_unitary) = loop2(loop1 x xs) in
  64             (unitary,x::non_unitary)
  65           else
  66             let (unitary,non_unitary) = loop2 (y::xs) in
  67             (x::unitary,non_unitary) in
  68     loop2 free_usage in
  69
  70   (* considers a list of lists *)
  71   let detect_unitary_frees l =
  72     let (unitary,nonunitary) =
  73       List.split (List.map collect_unitary_nonunitary l) in
  74     let unitary = nub (List.concat unitary) in
  75     let nonunitary = nub (List.concat nonunitary) in
  76     let unitary =
  77       List.filter (function x -> not (List.mem x nonunitary)) unitary in
  78     unitary@nonunitary@nonunitary in
  79
  80   let whencode afn bfn expression = function
  81       Ast0.WhenNot(a) -> afn a
  82     | Ast0.WhenAlways(b) -> bfn b
  83     | Ast0.WhenModifier(_) -> option_default
  84     | Ast0.WhenNotTrue(a) -> expression a
  85     | Ast0.WhenNotFalse(a) -> expression a in
  86
  87   let ident r k i =
  88     match Ast0.unwrap i with
  89       Ast0.MetaId(name,_,_) | Ast0.MetaFunc(name,_,_)
  90     | Ast0.MetaLocalFunc(name,_,_) -> checker name
  91     | _ -> k i in
  92
  93   let expression r k e =
  94     match Ast0.unwrap e with
  95       Ast0.MetaErr(name,_,_) | Ast0.MetaExpr(name,_,_,_,_)
  96     | Ast0.MetaExprList(name,_,_) -> checker name
  97     | Ast0.DisjExpr(starter,expr_list,mids,ender) ->
  98         detect_unitary_frees(List.map r.V0.combiner_expression expr_list)
  99     | _ -> k e in
 100
 101   let typeC r k t =
 102     match Ast0.unwrap t with
 103       Ast0.MetaType(name,_) -> checker name
 104     | Ast0.DisjType(starter,types,mids,ender) ->
 105         detect_unitary_frees(List.map r.V0.combiner_typeC types)
 106     | _ -> k t in
 107
 108   let parameter r k p =
 109     match Ast0.unwrap p with
 110       Ast0.MetaParam(name,_) | Ast0.MetaParamList(name,_,_) -> checker name
 111     | _ -> k p in
 112
 113   let declaration r k d =
 114     match Ast0.unwrap d with
 115       Ast0.DisjDecl(starter,decls,mids,ender) ->
 116         detect_unitary_frees(List.map r.V0.combiner_declaration decls)
 117     | _ -> k d in
 118
 119   let statement r k s =
 120     match Ast0.unwrap s with
 121       Ast0.MetaStmt(name,_) | Ast0.MetaStmtList(name,_) -> checker name
 122     | Ast0.Disj(starter,stmt_list,mids,ender) ->
 123         detect_unitary_frees(List.map r.V0.combiner_statement_dots stmt_list)
 124     | Ast0.Nest(starter,stmt_dots,ender,whn,multi) ->
 125         bind (r.V0.combiner_statement_dots stmt_dots)
 126           (detect_unitary_frees
 127              (List.map
 128                 (whencode r.V0.combiner_statement_dots r.V0.combiner_statement
 129                     r.V0.combiner_expression)
 130                 whn))
 131     | Ast0.Dots(d,whn) | Ast0.Circles(d,whn) | Ast0.Stars(d,whn) ->
 132         detect_unitary_frees
 133           (List.map
 134              (whencode r.V0.combiner_statement_dots r.V0.combiner_statement
 135                 r.V0.combiner_expression)
 136              whn)
 137     | _ -> k s in
 138
 139   let res = V0.combiner bind option_default
 140       mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 141       mcode
 142       donothing donothing donothing donothing donothing donothing
 143       ident expression typeC donothing parameter declaration statement
 144       donothing donothing in
 145
 146   collect_unitary_nonunitary
 147     (List.concat (List.map res.V0.combiner_top_level t))
 148
 149 (* ----------------------------------------------------------------------- *)
 150 (* update the variables that are unitary *)
 151
 152 let update_unitary unitary =
 153   let donothing r k e = k e in
 154   let mcode x = x in
 155
 156   let is_unitary name =
 157     match (List.mem (Ast0.unwrap_mcode name) unitary,
 158            !Flag.sgrep_mode2, Ast0.get_mcode_mcodekind name) with
 159       (true,true,_) | (true,_,Ast0.CONTEXT(_)) -> Ast0.PureContext
 160     | (true,_,_) -> Ast0.Pure
 161     | (false,true,_) | (false,_,Ast0.CONTEXT(_)) -> Ast0.Context
 162     | (false,_,_) -> Ast0.Impure in
 163
 164   let ident r k i =
 165     match Ast0.unwrap i with
 166       Ast0.MetaId(name,constraints,_) ->
 167         Ast0.rewrap i (Ast0.MetaId(name,constraints,is_unitary name))
 168     | Ast0.MetaFunc(name,constraints,_) ->
 169         Ast0.rewrap i (Ast0.MetaFunc(name,constraints,is_unitary name))
 170     | Ast0.MetaLocalFunc(name,constraints,_) ->
 171         Ast0.rewrap i (Ast0.MetaLocalFunc(name,constraints,is_unitary name))
 172     | _ -> k i in
 173
 174   let expression r k e =
 175     match Ast0.unwrap e with
 176       Ast0.MetaErr(name,constraints,_) ->
 177         Ast0.rewrap e (Ast0.MetaErr(name,constraints,is_unitary name))
 178     | Ast0.MetaExpr(name,constraints,ty,form,_) ->
 179         Ast0.rewrap e (Ast0.MetaExpr(name,constraints,ty,form,is_unitary name))
 180     | Ast0.MetaExprList(name,lenname,_) ->
 181         Ast0.rewrap e (Ast0.MetaExprList(name,lenname,is_unitary name))
 182     | _ -> k e in
 183
 184   let typeC r k t =
 185     match Ast0.unwrap t with
 186       Ast0.MetaType(name,_) ->
 187         Ast0.rewrap t (Ast0.MetaType(name,is_unitary name))
 188     | _ -> k t in
 189
 190   let parameter r k p =
 191     match Ast0.unwrap p with
 192       Ast0.MetaParam(name,_) ->
 193         Ast0.rewrap p (Ast0.MetaParam(name,is_unitary name))
 194     | Ast0.MetaParamList(name,lenname,_) ->
 195         Ast0.rewrap p (Ast0.MetaParamList(name,lenname,is_unitary name))
 196     | _ -> k p in
 197
 198   let statement r k s =
 199     match Ast0.unwrap s with
 200       Ast0.MetaStmt(name,_) ->
 201         Ast0.rewrap s (Ast0.MetaStmt(name,is_unitary name))
 202     | Ast0.MetaStmtList(name,_) ->
 203         Ast0.rewrap s (Ast0.MetaStmtList(name,is_unitary name))
 204     | _ -> k s in
 205
 206   let res = V0.rebuilder
 207       mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 208       mcode
 209       donothing donothing donothing donothing donothing donothing
 210       ident expression typeC donothing parameter donothing statement
 211       donothing donothing in
 212
 213   List.map res.V0.rebuilder_top_level
 214
 215 (* ----------------------------------------------------------------------- *)
 216
 217 let rec split3 = function
 218     [] -> ([],[],[])
 219   | (a,b,c)::xs -> let (l1,l2,l3) = split3 xs in (a::l1,b::l2,c::l3)
 220
 221 let rec combine3 = function
 222     ([],[],[]) -> []
 223   | (a::l1,b::l2,c::l3) -> (a,b,c) :: combine3 (l1,l2,l3)
 224   | _ -> failwith "not possible"
 225
 226 (* ----------------------------------------------------------------------- *)
 227 (* process all rules *)
 228
 229 let do_unitary rules =
 230   let rec loop = function
 231       [] -> ([],[])
 232     | (r::rules) ->
 233       match r with
 234         Ast0.ScriptRule (a,b,c,d) ->
 235           let (x,rules) = loop rules in
 236           (x, r::rules)
 237       | Ast0.CocciRule ((minus,metavars,chosen_isos),((plus,_) as plusz)) ->
 238           let mm1 = List.map Ast.get_meta_name metavars in
 239           let (used_after, rest) = loop rules in
 240           let (m_unitary, m_nonunitary) = get_free minus_checker minus in
 241           let (p_unitary, p_nonunitary) = get_free plus_checker plus in
 242           let p_free =
 243             if !Flag.sgrep_mode2 then []
 244             else p_unitary @ p_nonunitary in
 245           let (in_p, m_unitary) =
 246             List.partition (function x -> List.mem x p_free) m_unitary in
 247           let m_nonunitary = in_p @ m_nonunitary in
 248           let (m_unitary, not_local) =
 249             List.partition (function x -> List.mem x mm1) m_unitary in
 250           let m_unitary =
 251             List.filter (function x -> not (List.mem x used_after))
 252               m_unitary in
 253           let rebuilt = update_unitary m_unitary minus in
 254           (set_minus (m_nonunitary @ used_after) mm1,
 255              (Ast0.CocciRule
 256                 ((rebuilt, metavars, chosen_isos),plusz))::rest) in
 257   let (_,rules) = loop rules in
 258   rules
 259
 260 (*
 261 let do_unitary minus plus =
 262   let (minus,metavars,chosen_isos) = split3 minus in
 263   let (plus,_) = List.split plus in
 264   let rec loop = function
 265       ([],[],[]) -> ([],[])
 266     | (mm1::metavars,m1::minus,p1::plus) ->
 267         let mm1 = List.map Ast.get_meta_name mm1 in
 268         let (used_after,rest) = loop (metavars,minus,plus) in
 269         let (m_unitary,m_nonunitary) = get_free minus_checker m1 in
 270         let (p_unitary,p_nonunitary) = get_free plus_checker p1 in
 271         let p_free =
 272           if !Flag.sgrep_mode2
 273           then []
 274           else p_unitary @ p_nonunitary in
 275         let (in_p,m_unitary) =
 276           List.partition (function x -> List.mem x p_free) m_unitary in
 277         let m_nonunitary = in_p@m_nonunitary in
 278         let (m_unitary,not_local) =
 279           List.partition (function x -> List.mem x mm1) m_unitary in
 280         let m_unitary =
 281           List.filter (function x -> not(List.mem x used_after)) m_unitary in
 282         let rebuilt = update_unitary m_unitary m1 in
 283         (set_minus (m_nonunitary @ used_after) mm1,
 284          rebuilt::rest)
 285     | _ -> failwith "not possible" in
 286   let (_,rules) = loop (metavars,minus,plus) in
 287   combine3 (rules,metavars,chosen_isos)
 288 *)