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.
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.
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.
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/>.
18 * The authors reserve the right to distribute this or future versions of
19 * Coccinelle under other licenses.
23 (* find unitary metavariables *)
24 module Ast0 = Ast0_cocci
25 module Ast = Ast_cocci
26 module V0 = Visitor_ast0
28 let set_minus s minus = List.filter (function n -> not (List.mem n minus)) s
30 let rec nub = function
32 | (x::xs) when (List.mem x xs) -> nub xs
33 | (x::xs) -> x::(nub xs)
35 (* ----------------------------------------------------------------------- *)
36 (* Find the variables that occur free and occur free in a unitary way *)
39 let minus_checker name = let id = Ast0.unwrap_mcode name in [id]
41 (* take only what is in the plus code *)
42 let plus_checker (nm,_,_,mc,_) =
43 match mc with Ast0.PLUS -> [nm] | _ -> []
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
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
56 | (x::xs) as all -> if x = todrop then loop1 todrop xs else all in
57 let rec loop2 = function
63 let (unitary,non_unitary) = loop2(loop1 x xs) in
64 (unitary,x::non_unitary)
66 let (unitary,non_unitary) = loop2 (y::xs) in
67 (x::unitary,non_unitary) in
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
77 List.filter (function x -> not (List.mem x nonunitary)) unitary in
78 unitary@nonunitary@nonunitary in
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
88 match Ast0.unwrap i with
89 Ast0.MetaId(name,_,_) | Ast0.MetaFunc(name,_,_)
90 | Ast0.MetaLocalFunc(name,_,_) -> checker name
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)
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)
108 let parameter r k p =
109 match Ast0.unwrap p with
110 Ast0.MetaParam(name,_) | Ast0.MetaParamList(name,_,_) -> checker name
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)
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
128 (whencode r.V0.combiner_statement_dots r.V0.combiner_statement
129 r.V0.combiner_expression)
131 | Ast0.Dots(d,whn) | Ast0.Circles(d,whn) | Ast0.Stars(d,whn) ->
134 (whencode r.V0.combiner_statement_dots r.V0.combiner_statement
135 r.V0.combiner_expression)
139 let res = V0.combiner bind option_default
140 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
142 donothing donothing donothing donothing donothing donothing
143 ident expression typeC donothing parameter declaration statement
144 donothing donothing in
146 collect_unitary_nonunitary
147 (List.concat (List.map res.V0.combiner_top_level t))
149 (* ----------------------------------------------------------------------- *)
150 (* update the variables that are unitary *)
152 let update_unitary unitary =
153 let donothing r k e = k e in
156 let is_unitary name =
157 match (List.mem (Ast0.unwrap_mcode name) unitary,
158 Ast0.get_mcode_mcodekind name) with
159 (true,Ast0.CONTEXT(mc)) -> Ast0.PureContext
160 | (true,_) -> Ast0.Pure
161 | (false,Ast0.CONTEXT(mc)) -> Ast0.Context
162 | (false,_) -> Ast0.Impure in
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))
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))
185 match Ast0.unwrap t with
186 Ast0.MetaType(name,_) ->
187 Ast0.rewrap t (Ast0.MetaType(name,is_unitary name))
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))
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))
206 let res = V0.rebuilder
207 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
209 donothing donothing donothing donothing donothing donothing
210 ident expression typeC donothing parameter donothing statement
211 donothing donothing in
213 List.map res.V0.rebuilder_top_level
215 (* ----------------------------------------------------------------------- *)
217 let rec split3 = function
219 | (a,b,c)::xs -> let (l1,l2,l3) = split3 xs in (a::l1,b::l2,c::l3)
221 let rec combine3 = function
223 | (a::l1,b::l2,c::l3) -> (a,b,c) :: combine3 (l1,l2,l3)
224 | _ -> failwith "not possible"
226 (* ----------------------------------------------------------------------- *)
227 (* process all rules *)
229 let do_unitary rules =
230 let rec loop = function
234 Ast0.ScriptRule (a,b,c,d) ->
235 let (x,rules) = loop rules in
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
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
251 List.filter (function x -> not (List.mem x used_after))
253 let rebuilt = update_unitary m_unitary minus in
254 (set_minus (m_nonunitary @ used_after) mm1,
256 ((rebuilt, metavars, chosen_isos),plusz))::rest) in
257 let (_,rules) = loop rules in
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
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
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,
285 | _ -> failwith "not possible" in
286 let (_,rules) = loop (metavars,minus,plus) in
287 combine3 (rules,metavars,chosen_isos)